Theory Laws
section ‹Generic laws about registers›
theory Laws
imports Axioms
begin
text ‹This notation is only used inside this file›
notation comp_update (infixl "*⇩u" 55)
notation tensor_update (infixr "⊗⇩u" 70)
notation register_pair ("'(_;_')")
subsection ‹Elementary facts›
declare id_preregister[simp]
declare id_update_left[simp]
declare id_update_right[simp]
declare register_preregister[simp]
declare register_comp[simp]
declare register_of_id[simp]
declare register_tensor_left[simp]
declare register_tensor_right[simp]
declare preregister_mult_right[simp]
declare preregister_mult_left[simp]
declare register_id[simp]
subsection ‹Preregisters›
lemma preregister_tensor_left[simp]: ‹preregister (λb::'b::domain update. tensor_update a b)›
for a :: ‹'a::domain update›
proof -
have ‹preregister ((λb1::('a×'b) update. (a ⊗⇩u id_update) *⇩u b1) o (λb. tensor_update id_update b))›
by (rule comp_preregister; simp)
then show ?thesis
by (simp add: o_def tensor_update_mult)
qed
lemma preregister_tensor_right[simp]: ‹preregister (λa::'a::domain update. tensor_update a b)›
for b :: ‹'b::domain update›
proof -
have ‹preregister ((λa1::('a×'b) update. (id_update ⊗⇩u b) *⇩u a1) o (λa. tensor_update a id_update))›
by (rule comp_preregister, simp_all)
then show ?thesis
by (simp add: o_def tensor_update_mult)
qed
subsection ‹Registers›
lemma id_update_tensor_register[simp]:
assumes ‹register F›
shows ‹register (λa::'a::domain update. id_update ⊗⇩u F a)›
using assms apply (rule register_comp[unfolded o_def])
by simp
lemma register_tensor_id_update[simp]:
assumes ‹register F›
shows ‹register (λa::'a::domain update. F a ⊗⇩u id_update)›
using assms apply (rule register_comp[unfolded o_def])
by simp
subsection ‹Tensor product of registers›
definition register_tensor (infixr "⊗⇩r" 70) where
"register_tensor F G = register_pair (λa. tensor_update (F a) id_update) (λb. tensor_update id_update (G b))"
lemma register_tensor_is_register:
fixes F :: "'a::domain update ⇒ 'b::domain update" and G :: "'c::domain update ⇒ 'd::domain update"
shows "register F ⟹ register G ⟹ register (F ⊗⇩r G)"
unfolding register_tensor_def
apply (rule register_pair_is_register)
by (simp_all add: tensor_update_mult)
lemma register_tensor_apply[simp]:
fixes F :: "'a::domain update ⇒ 'b::domain update" and G :: "'c::domain update ⇒ 'd::domain update"
assumes ‹register F› and ‹register G›
shows "(F ⊗⇩r G) (a ⊗⇩u b) = F a ⊗⇩u G b"
unfolding register_tensor_def
apply (subst register_pair_apply)
unfolding register_tensor_def
by (simp_all add: assms tensor_update_mult)
definition "separating (_::'b::domain itself) A ⟷
(∀F G :: 'a::domain update ⇒ 'b update. preregister F ⟶ preregister G ⟶ (∀x∈A. F x = G x) ⟶ F = G)"
lemma separating_UNIV[simp]: ‹separating TYPE(_) UNIV›
unfolding separating_def by auto
lemma separating_mono: ‹A ⊆ B ⟹ separating TYPE('a::domain) A ⟹ separating TYPE('a) B›
unfolding separating_def by (meson in_mono)
lemma register_eqI: ‹separating TYPE('b::domain) A ⟹ preregister F ⟹ preregister G ⟹ (⋀x. x∈A ⟹ F x = G x) ⟹ F = (G::_ ⇒ 'b update)›
unfolding separating_def by auto
lemma separating_tensor:
fixes A :: ‹'a::domain update set› and B :: ‹'b::domain update set›
assumes [simp]: ‹separating TYPE('c::domain) A›
assumes [simp]: ‹separating TYPE('c) B›
shows ‹separating TYPE('c) {a ⊗⇩u b | a b. a∈A ∧ b∈B}›
proof (unfold separating_def, intro allI impI)
fix F G :: ‹('a×'b) update ⇒ 'c update›
assume [simp]: ‹preregister F› ‹preregister G›
have [simp]: ‹preregister (λx. F (a ⊗⇩u x))› for a
using _ ‹preregister F› apply (rule comp_preregister[unfolded o_def])
by simp
have [simp]: ‹preregister (λx. G (a ⊗⇩u x))› for a
using _ ‹preregister G› apply (rule comp_preregister[unfolded o_def])
by simp
have [simp]: ‹preregister (λx. F (x ⊗⇩u b))› for b
using _ ‹preregister F› apply (rule comp_preregister[unfolded o_def])
by simp
have [simp]: ‹preregister (λx. G (x ⊗⇩u b))› for b
using _ ‹preregister G› apply (rule comp_preregister[unfolded o_def])
by simp
assume ‹∀x∈{a ⊗⇩u b |a b. a∈A ∧ b∈B}. F x = G x›
then have EQ: ‹F (a ⊗⇩u b) = G (a ⊗⇩u b)› if ‹a ∈ A› and ‹b ∈ B› for a b
using that by auto
then have ‹F (a ⊗⇩u b) = G (a ⊗⇩u b)› if ‹a ∈ A› for a b
apply (rule register_eqI[where A=B, THEN fun_cong, where x=b, rotated -1])
using that by auto
then have ‹F (a ⊗⇩u b) = G (a ⊗⇩u b)› for a b
apply (rule register_eqI[where A=A, THEN fun_cong, where x=a, rotated -1])
by auto
then show "F = G"
apply (rule tensor_extensionality[rotated -1])
by auto
qed
lemma register_tensor_distrib:
assumes [simp]: ‹register F› ‹register G› ‹register H› ‹register L›
shows ‹(F ⊗⇩r G) o (H ⊗⇩r L) = (F o H) ⊗⇩r (G o L)›
apply (rule tensor_extensionality)
by (auto intro!: register_comp register_preregister register_tensor_is_register)
text ‹The following is easier to apply using the @{method rule}-method than @{thm [source] separating_tensor}›
lemma separating_tensor':
fixes A :: ‹'a::domain update set› and B :: ‹'b::domain update set›
assumes ‹separating TYPE('c::domain) A›
assumes ‹separating TYPE('c) B›
assumes ‹C = {a ⊗⇩u b | a b. a∈A ∧ b∈B}›
shows ‹separating TYPE('c) C›
using assms
by (simp add: separating_tensor)
lemma tensor_extensionality3:
fixes F G :: ‹('a::domain×'b::domain×'c::domain) update ⇒ 'd::domain update›
assumes [simp]: ‹register F› ‹register G›
assumes "⋀f g h. F (f ⊗⇩u g ⊗⇩u h) = G (f ⊗⇩u g ⊗⇩u h)"
shows "F = G"
proof (rule register_eqI[where A=‹{a⊗⇩ub⊗⇩uc| a b c. True}›])
have ‹separating TYPE('d) {b ⊗⇩u c |b c. True}›
apply (rule separating_tensor'[where A=UNIV and B=UNIV])
by auto
then show ‹separating TYPE('d) {a ⊗⇩u b ⊗⇩u c |a b c. True}›
apply (rule_tac separating_tensor'[where A=UNIV and B=‹{b⊗⇩uc| b c. True}›])
by auto
show ‹preregister F› ‹preregister G› by auto
show ‹x ∈ {a ⊗⇩u b ⊗⇩u c |a b c. True} ⟹ F x = G x› for x
using assms(3) by auto
qed
lemma tensor_extensionality3':
fixes F G :: ‹(('a::domain×'b::domain)×'c::domain) update ⇒ 'd::domain update›
assumes [simp]: ‹register F› ‹register G›
assumes "⋀f g h. F ((f ⊗⇩u g) ⊗⇩u h) = G ((f ⊗⇩u g) ⊗⇩u h)"
shows "F = G"
proof (rule register_eqI[where A=‹{(a⊗⇩ub)⊗⇩uc| a b c. True}›])
have ‹separating TYPE('d) {a ⊗⇩u b | a b. True}›
apply (rule separating_tensor'[where A=UNIV and B=UNIV])
by auto
then show ‹separating TYPE('d) {(a ⊗⇩u b) ⊗⇩u c |a b c. True}›
apply (rule_tac separating_tensor'[where B=UNIV and A=‹{a⊗⇩ub| a b. True}›])
by auto
show ‹preregister F› ‹preregister G› by auto
show ‹x ∈ {(a ⊗⇩u b) ⊗⇩u c |a b c. True} ⟹ F x = G x› for x
using assms(3) by auto
qed
lemma register_tensor_id[simp]: ‹id ⊗⇩r id = id›
apply (rule tensor_extensionality)
by (auto simp add: register_tensor_is_register)
subsection ‹Pairs and compatibility›
definition compatible :: ‹('a::domain update ⇒ 'c::domain update)
⇒ ('b::domain update ⇒ 'c update) ⇒ bool› where
‹compatible F G ⟷ register F ∧ register G ∧ (∀a b. F a *⇩u G b = G b *⇩u F a)›
lemma compatibleI:
assumes "register F" and "register G"
assumes ‹⋀a b. (F a) *⇩u (G b) = (G b) *⇩u (F a)›
shows "compatible F G"
using assms unfolding compatible_def by simp
lemma swap_registers:
assumes "compatible R S"
shows "R a *⇩u S b = S b *⇩u R a"
using assms unfolding compatible_def by metis
lemma compatible_sym: "compatible x y ⟹ compatible y x"
by (simp add: compatible_def)
lemma pair_is_register[simp]:
assumes "compatible F G"
shows "register (F; G)"
by (metis assms compatible_def register_pair_is_register)
lemma register_pair_apply:
assumes ‹compatible F G›
shows ‹(F; G) (a ⊗⇩u b) = (F a) *⇩u (G b)›
apply (rule register_pair_apply)
using assms unfolding compatible_def by metis+
lemma register_pair_apply':
assumes ‹compatible F G›
shows ‹(F; G) (a ⊗⇩u b) = (G b) *⇩u (F a)›
apply (subst register_pair_apply)
using assms by (auto simp: compatible_def intro: register_preregister)
lemma compatible_comp_left[simp]: "compatible F G ⟹ register H ⟹ compatible (F ∘ H) G"
by (simp add: compatible_def)
lemma compatible_comp_right[simp]: "compatible F G ⟹ register H ⟹ compatible F (G ∘ H)"
by (simp add: compatible_def)
lemma compatible_comp_inner[simp]:
"compatible F G ⟹ register H ⟹ compatible (H ∘ F) (H ∘ G)"
by (smt (verit, best) comp_apply compatible_def register_comp register_mult)
lemma compatible_register1: ‹compatible F G ⟹ register F›
by (simp add: compatible_def)
lemma compatible_register2: ‹compatible F G ⟹ register G›
by (simp add: compatible_def)
lemma pair_o_tensor:
assumes "compatible A B" and [simp]: ‹register C› and [simp]: ‹register D›
shows "(A; B) o (C ⊗⇩r D) = (A o C; B o D)"
apply (rule tensor_extensionality)
using assms by (simp_all add: register_tensor_is_register register_pair_apply comp_preregister)
lemma compatible_tensor_id_update_left[simp]:
fixes F :: "'a::domain update ⇒ 'c::domain update" and G :: "'b::domain update ⇒ 'c::domain update"
assumes "compatible F G"
shows "compatible (λa. id_update ⊗⇩u F a) (λa. id_update ⊗⇩u G a)"
using assms apply (rule compatible_comp_inner[unfolded o_def])
by simp
lemma compatible_tensor_id_update_right[simp]:
fixes F :: "'a::domain update ⇒ 'c::domain update" and G :: "'b::domain update ⇒ 'c::domain update"
assumes "compatible F G"
shows "compatible (λa. F a ⊗⇩u id_update) (λa. G a ⊗⇩u id_update)"
using assms apply (rule compatible_comp_inner[unfolded o_def])
by simp
lemma compatible_tensor_id_update_rl[simp]:
assumes "register F" and "register G"
shows "compatible (λa. F a ⊗⇩u id_update) (λa. id_update ⊗⇩u G a)"
apply (rule compatibleI)
using assms by (auto simp: tensor_update_mult)
lemma compatible_tensor_id_update_lr[simp]:
assumes "register F" and "register G"
shows "compatible (λa. id_update ⊗⇩u F a) (λa. G a ⊗⇩u id_update)"
apply (rule compatibleI)
using assms by (auto simp: tensor_update_mult)
lemma register_comp_pair:
assumes [simp]: ‹register F› and [simp]: ‹compatible G H›
shows "(F o G; F o H) = F o (G; H)"
proof (rule tensor_extensionality)
show ‹preregister (F ∘ G;F ∘ H)› and ‹preregister (F ∘ (G;H))›
by simp_all
have [simp]: ‹compatible (F o G) (F o H)›
apply (rule compatible_comp_inner, simp)
by simp
then have [simp]: ‹register (F ∘ G)› ‹register (F ∘ H)›
unfolding compatible_def by auto
from assms have [simp]: ‹register G› ‹register H›
unfolding compatible_def by auto
fix a b
show ‹(F ∘ G;F ∘ H) (a ⊗⇩u b) = (F ∘ (G;H)) (a ⊗⇩u b)›
by (auto simp: register_pair_apply register_mult tensor_update_mult)
qed
lemma swap_registers_left:
assumes "compatible R S"
shows "R a *⇩u S b *⇩u c = S b *⇩u R a *⇩u c"
using assms unfolding compatible_def by metis
lemma swap_registers_right:
assumes "compatible R S"
shows "c *⇩u R a *⇩u S b = c *⇩u S b *⇩u R a"
by (metis assms comp_update_assoc compatible_def)
lemmas compatible_ac_rules = swap_registers comp_update_assoc[symmetric] swap_registers_right
subsection ‹Fst and Snd›
definition Fst where ‹Fst a = a ⊗⇩u id_update›
definition Snd where ‹Snd a = id_update ⊗⇩u a›
lemma register_Fst[simp]: ‹register Fst›
unfolding Fst_def by (rule register_tensor_left)
lemma register_Snd[simp]: ‹register Snd›
unfolding Snd_def by (rule register_tensor_right)
lemma compatible_Fst_Snd[simp]: ‹compatible Fst Snd›
apply (rule compatibleI, simp, simp)
by (simp add: Fst_def Snd_def tensor_update_mult)
lemmas compatible_Snd_Fst[simp] = compatible_Fst_Snd[THEN compatible_sym]
definition ‹swap = (Snd; Fst)›
lemma swap_apply[simp]: "swap (a ⊗⇩u b) = (b ⊗⇩u a)"
unfolding swap_def
by (simp add: Axioms.register_pair_apply Fst_def Snd_def tensor_update_mult)
lemma swap_o_Fst: "swap o Fst = Snd"
by (auto simp add: Fst_def Snd_def)
lemma swap_o_Snd: "swap o Snd = Fst"
by (auto simp add: Fst_def Snd_def)
lemma register_swap[simp]: ‹register swap›
by (simp add: swap_def)
lemma pair_Fst_Snd: ‹(Fst; Snd) = id›
apply (rule tensor_extensionality)
by (simp_all add: register_pair_apply Fst_def Snd_def tensor_update_mult)
lemma swap_o_swap[simp]: ‹swap o swap = id›
by (metis swap_def compatible_Snd_Fst pair_Fst_Snd register_comp_pair register_swap swap_o_Fst swap_o_Snd)
lemma swap_swap[simp]: ‹swap (swap x) = x›
by (simp add: pointfree_idE)
lemma inv_swap[simp]: ‹inv swap = swap›
by (meson inv_unique_comp swap_o_swap)
lemma register_pair_Fst:
assumes ‹compatible F G›
shows ‹(F;G) o Fst = F›
using assms by (auto intro!: ext simp: Fst_def register_pair_apply compatible_register2)
lemma register_pair_Snd:
assumes ‹compatible F G›
shows ‹(F;G) o Snd = G›
using assms by (auto intro!: ext simp: Snd_def register_pair_apply compatible_register1)
lemma register_Fst_register_Snd[simp]:
assumes ‹register F›
shows ‹(F o Fst; F o Snd) = F›
apply (rule tensor_extensionality)
using assms by (auto simp: register_pair_apply Fst_def Snd_def register_mult tensor_update_mult)
lemma register_Snd_register_Fst[simp]:
assumes ‹register F›
shows ‹(F o Snd; F o Fst) = F o swap›
apply (rule tensor_extensionality)
using assms by (auto simp: register_pair_apply Fst_def Snd_def register_mult tensor_update_mult)
lemma compatible3[simp]:
assumes [simp]: "compatible F G" and "compatible G H" and "compatible F H"
shows "compatible (F; G) H"
proof (rule compatibleI)
have [simp]: ‹register F› ‹register G› ‹register H›
using assms compatible_def by auto
then have [simp]: ‹preregister F› ‹preregister G› ‹preregister H›
using register_preregister by blast+
have [simp]: ‹preregister (λa. (F;G) a *⇩u z)› for z
apply (rule comp_preregister[unfolded o_def, of ‹(F;G)›])
by simp_all
have [simp]: ‹preregister (λa. z *⇩u (F;G) a)› for z
apply (rule comp_preregister[unfolded o_def, of ‹(F;G)›])
by simp_all
have "(F; G) (f ⊗⇩u g) *⇩u H h = H h *⇩u (F; G) (f ⊗⇩u g)" for f g h
proof -
have FH: "F f *⇩u H h = H h *⇩u F f"
using assms compatible_def by metis
have GH: "G g *⇩u H h = H h *⇩u G g"
using assms compatible_def by metis
have ‹(F; G) (f ⊗⇩u g) *⇩u (H h) = F f *⇩u G g *⇩u H h›
using ‹compatible F G› by (subst register_pair_apply, auto)
also have ‹… = H h *⇩u F f *⇩u G g›
using FH GH by (metis comp_update_assoc)
also have ‹… = H h *⇩u (F; G) (f ⊗⇩u g)›
using ‹compatible F G› by (subst register_pair_apply, auto simp: comp_update_assoc)
finally show ?thesis
by -
qed
then show "(F; G) fg *⇩u (H h) = (H h) *⇩u (F; G) fg" for fg h
apply (rule_tac tensor_extensionality[THEN fun_cong])
by auto
show "register H" and "register (F; G)"
by simp_all
qed
lemma compatible3'[simp]:
assumes "compatible F G" and "compatible G H" and "compatible F H"
shows "compatible F (G; H)"
apply (rule compatible_sym)
apply (rule compatible3)
using assms by (auto simp: compatible_sym)
lemma pair_o_swap[simp]:
assumes [simp]: "compatible A B"
shows "(A; B) o swap = (B; A)"
proof (rule tensor_extensionality)
have [simp]: "preregister A" "preregister B"
apply (metis (no_types, opaque_lifting) assms compatible_register1 register_preregister)
by (metis (full_types) assms compatible_register2 register_preregister)
then show ‹preregister ((A; B) ∘ swap)›
by simp
show ‹preregister (B; A)›
by (metis (no_types, lifting) assms compatible_sym register_preregister pair_is_register)
show ‹((A; B) ∘ swap) (a ⊗⇩u b) = (B; A) (a ⊗⇩u b)› for a b
apply (simp only: o_def swap_apply)
apply (subst register_pair_apply, simp)
apply (subst register_pair_apply, simp add: compatible_sym)
by (metis (no_types, lifting) assms compatible_def)
qed
subsection ‹Compatibility of register tensor products›
lemma compatible_register_tensor:
fixes F :: ‹'a::domain update ⇒ 'e::domain update› and G :: ‹'b::domain update ⇒ 'f::domain update›
and F' :: ‹'c::domain update ⇒ 'e update› and G' :: ‹'d::domain update ⇒ 'f update›
assumes [simp]: ‹compatible F F'›
assumes [simp]: ‹compatible G G'›
shows ‹compatible (F ⊗⇩r G) (F' ⊗⇩r G')›
proof -
note [intro!] =
comp_preregister[OF _ preregister_mult_right, unfolded o_def]
comp_preregister[OF _ preregister_mult_left, unfolded o_def]
comp_preregister
register_tensor_is_register
have [simp]: ‹register F› ‹register G› ‹register F'› ‹register G'›
using assms compatible_def by blast+
have [simp]: ‹register (F ⊗⇩r G)› ‹register (F' ⊗⇩r G')›
by (auto simp add: register_tensor_def)
have [simp]: ‹register (F;F')› ‹register (G;G')›
by auto
define reorder :: ‹(('a×'b) × ('c×'d)) update ⇒ (('a×'c) × ('b×'d)) update›
where ‹reorder = ((Fst o Fst; Snd o Fst); (Fst o Snd; Snd o Snd))›
have [simp]: ‹preregister reorder›
by (auto simp: reorder_def)
have [simp]: ‹reorder ((a ⊗⇩u b) ⊗⇩u (c ⊗⇩u d)) = ((a ⊗⇩u c) ⊗⇩u (b ⊗⇩u d))› for a b c d
apply (simp add: reorder_def register_pair_apply)
by (simp add: Fst_def Snd_def tensor_update_mult)
define Φ where ‹Φ c d = ((F;F') ⊗⇩r (G;G')) o reorder o (λσ. σ ⊗⇩u (c ⊗⇩u d))› for c d
have [simp]: ‹preregister (Φ c d)› for c d
unfolding Φ_def
by (auto intro: register_preregister)
have ‹Φ c d (a ⊗⇩u b) = (F ⊗⇩r G) (a ⊗⇩u b) *⇩u (F' ⊗⇩r G') (c ⊗⇩u d)› for a b c d
unfolding Φ_def by (auto simp: register_pair_apply tensor_update_mult)
then have Φ1: ‹Φ c d σ = (F ⊗⇩r G) σ *⇩u (F' ⊗⇩r G') (c ⊗⇩u d)› for c d σ
apply (rule_tac fun_cong[of _ _ σ])
apply (rule tensor_extensionality)
by auto
have ‹Φ c d (a ⊗⇩u b) = (F' ⊗⇩r G') (c ⊗⇩u d) *⇩u (F ⊗⇩r G) (a ⊗⇩u b)› for a b c d
unfolding Φ_def apply (auto simp: register_pair_apply)
by (metis assms(1) assms(2) compatible_def tensor_update_mult)
then have Φ2: ‹Φ c d σ = (F' ⊗⇩r G') (c ⊗⇩u d) *⇩u (F ⊗⇩r G) σ› for c d σ
apply (rule_tac fun_cong[of _ _ σ])
apply (rule tensor_extensionality)
by auto
from Φ1 Φ2 have ‹(F ⊗⇩r G) σ *⇩u (F' ⊗⇩r G') τ = (F' ⊗⇩r G') τ *⇩u (F ⊗⇩r G) σ› for τ σ
apply (rule_tac fun_cong[of _ _ τ])
apply (rule tensor_extensionality)
by auto
then show ?thesis
apply (rule compatibleI[rotated -1])
by auto
qed
subsection ‹Associativity of the tensor product›
definition assoc :: ‹(('a::domain×'b::domain)×'c::domain) update ⇒ ('a×('b×'c)) update› where
‹assoc = ((Fst; Snd o Fst); Snd o Snd)›
lemma assoc_is_hom[simp]: ‹preregister assoc›
by (auto simp: assoc_def)
lemma assoc_apply[simp]: ‹assoc ((a ⊗⇩u b) ⊗⇩u c) = (a ⊗⇩u (b ⊗⇩u c))›
by (auto simp: assoc_def register_pair_apply Fst_def Snd_def tensor_update_mult)
definition assoc' :: ‹('a×('b×'c)) update ⇒ (('a::domain×'b::domain)×'c::domain) update› where
‹assoc' = (Fst o Fst; (Fst o Snd; Snd))›
lemma assoc'_is_hom[simp]: ‹preregister assoc'›
by (auto simp: assoc'_def)
lemma assoc'_apply[simp]: ‹assoc' (a ⊗⇩u (b ⊗⇩u c)) = ((a ⊗⇩u b) ⊗⇩u c)›
by (auto simp: assoc'_def register_pair_apply Fst_def Snd_def tensor_update_mult)
lemma register_assoc[simp]: ‹register assoc›
unfolding assoc_def
by force
lemma register_assoc'[simp]: ‹register assoc'›
unfolding assoc'_def
by force
lemma pair_o_assoc[simp]:
assumes [simp]: ‹compatible F G› ‹compatible G H› ‹compatible F H›
shows ‹(F; (G; H)) ∘ assoc = ((F; G); H)›
proof (rule tensor_extensionality3')
show ‹register ((F; (G; H)) ∘ assoc)›
by simp
show ‹register ((F; G); H)›
by simp
show ‹((F; (G; H)) ∘ assoc) ((f ⊗⇩u g) ⊗⇩u h) = ((F; G); H) ((f ⊗⇩u g) ⊗⇩u h)› for f g h
by (simp add: register_pair_apply assoc_apply comp_update_assoc)
qed
lemma pair_o_assoc'[simp]:
assumes [simp]: ‹compatible F G› ‹compatible G H› ‹compatible F H›
shows ‹((F; G); H) ∘ assoc' = (F; (G; H))›
proof (rule tensor_extensionality3)
show ‹register (((F; G); H) ∘ assoc')›
by simp
show ‹register (F; (G; H))›
by simp
show ‹(((F; G); H) ∘ assoc') (f ⊗⇩u g ⊗⇩u h) = (F; (G; H)) (f ⊗⇩u g ⊗⇩u h)› for f g h
by (simp add: register_pair_apply assoc'_apply comp_update_assoc)
qed
lemma assoc'_o_assoc[simp]: ‹assoc' o assoc = id›
apply (rule tensor_extensionality3')
by auto
lemma assoc'_assoc[simp]: ‹assoc' (assoc x) = x›
by (simp add: pointfree_idE)
lemma assoc_o_assoc'[simp]: ‹assoc o assoc' = id›
apply (rule tensor_extensionality3)
by auto
lemma assoc_assoc'[simp]: ‹assoc (assoc' x) = x›
by (simp add: pointfree_idE)
lemma inv_assoc[simp]: ‹inv assoc = assoc'›
using assoc'_o_assoc assoc_o_assoc' inv_unique_comp by blast
lemma inv_assoc'[simp]: ‹inv assoc' = assoc›
by (simp add: inv_equality)
lemma [simp]: ‹bij assoc›
using assoc'_o_assoc assoc_o_assoc' o_bij by blast
lemma [simp]: ‹bij assoc'›
using assoc'_o_assoc assoc_o_assoc' o_bij by blast
subsection ‹Iso-registers›
definition ‹iso_register F ⟷ register F ∧ (∃G. register G ∧ F o G = id ∧ G o F = id)›
for F :: ‹_::domain update ⇒ _::domain update›
lemma iso_registerI:
assumes ‹register F› ‹register G› ‹F o G = id› ‹G o F = id›
shows ‹iso_register F›
using assms(1) assms(2) assms(3) assms(4) iso_register_def by blast
lemma iso_register_inv: ‹iso_register F ⟹ iso_register (inv F)›
by (metis inv_unique_comp iso_register_def)
lemma iso_register_inv_comp1: ‹iso_register F ⟹ inv F o F = id›
using inv_unique_comp iso_register_def by blast
lemma iso_register_inv_comp2: ‹iso_register F ⟹ F o inv F = id›
using inv_unique_comp iso_register_def by blast
lemma iso_register_id[simp]: ‹iso_register id›
by (simp add: iso_register_def)
lemma iso_register_is_register: ‹iso_register F ⟹ register F›
using iso_register_def by blast
lemma iso_register_comp[simp]:
assumes [simp]: ‹iso_register F› ‹iso_register G›
shows ‹iso_register (F o G)›
proof -
from assms obtain F' G' where [simp]: ‹register F'› ‹register G'› ‹F o F' = id› ‹F' o F = id›
‹G o G' = id› ‹G' o G = id›
by (meson iso_register_def)
show ?thesis
apply (rule iso_registerI[where G=‹G' o F'›])
apply (auto simp: register_tensor_is_register iso_register_is_register register_tensor_distrib)
apply (metis ‹F ∘ F' = id› ‹G ∘ G' = id› fcomp_assoc fcomp_comp id_fcomp)
by (metis (no_types, lifting) ‹F ∘ F' = id› ‹F' ∘ F = id› ‹G' ∘ G = id› fun.map_comp inj_iff inv_unique_comp o_inv_o_cancel)
qed
lemma iso_register_tensor_is_iso_register[simp]:
assumes [simp]: ‹iso_register F› ‹iso_register G›
shows ‹iso_register (F ⊗⇩r G)›
proof -
from assms obtain F' G' where [simp]: ‹register F'› ‹register G'› ‹F o F' = id› ‹F' o F = id›
‹G o G' = id› ‹G' o G = id›
by (meson iso_register_def)
show ?thesis
apply (rule iso_registerI[where G=‹F' ⊗⇩r G'›])
by (auto simp: register_tensor_is_register iso_register_is_register register_tensor_distrib)
qed
lemma iso_register_bij: ‹iso_register F ⟹ bij F›
using iso_register_def o_bij by auto
lemma inv_register_tensor[simp]:
assumes [simp]: ‹iso_register F› ‹iso_register G›
shows ‹inv (F ⊗⇩r G) = inv F ⊗⇩r inv G›
apply (auto intro!: inj_imp_inv_eq bij_is_inj iso_register_bij
simp: register_tensor_distrib[unfolded o_def, THEN fun_cong] iso_register_is_register
iso_register_inv bij_is_surj iso_register_bij surj_f_inv_f)
by (metis eq_id_iff register_tensor_id)
lemma iso_register_swap[simp]: ‹iso_register swap›
apply (rule iso_registerI[of _ swap])
by auto
lemma iso_register_assoc[simp]: ‹iso_register assoc›
apply (rule iso_registerI[of _ assoc'])
by auto
lemma iso_register_assoc'[simp]: ‹iso_register assoc'›
apply (rule iso_registerI[of _ assoc])
by auto
definition ‹equivalent_registers F G ⟷ (register F ∧ (∃I. iso_register I ∧ F o I = G))›
for F G :: ‹_::domain update ⇒ _::domain update›
lemma iso_register_equivalent_id[simp]: ‹equivalent_registers id F ⟷ iso_register F›
by (simp add: equivalent_registers_def)
lemma equivalent_registersI:
assumes ‹register F›
assumes ‹iso_register I›
assumes ‹F o I = G›
shows ‹equivalent_registers F G›
using assms unfolding equivalent_registers_def by blast
lemma equivalent_registers_register_left: ‹equivalent_registers F G ⟹ register F›
using equivalent_registers_def by auto
lemma equivalent_registers_register_right: ‹register G› if ‹equivalent_registers F G›
by (metis equivalent_registers_def iso_register_def register_comp that)
lemma equivalent_registers_sym:
assumes ‹equivalent_registers F G›
shows ‹equivalent_registers G F›
by (smt (verit) assms comp_id equivalent_registers_def equivalent_registers_register_right fun.map_comp iso_register_def)
lemma equivalent_registers_trans[trans]:
assumes ‹equivalent_registers F G› and ‹equivalent_registers G H›
shows ‹equivalent_registers F H›
proof -
from assms have [simp]: ‹register F› ‹register G›
by (auto simp: equivalent_registers_def)
from assms(1) obtain I where [simp]: ‹iso_register I› and ‹F o I = G›
using equivalent_registers_def by blast
from assms(2) obtain J where [simp]: ‹iso_register J› and ‹G o J = H›
using equivalent_registers_def by blast
have ‹register F›
by (auto simp: equivalent_registers_def)
moreover have ‹iso_register (I o J)›
using ‹iso_register I› ‹iso_register J› iso_register_comp by blast
moreover have ‹F o (I o J) = H›
by (simp add: ‹F ∘ I = G› ‹G ∘ J = H› o_assoc)
ultimately show ?thesis
by (rule equivalent_registersI)
qed
lemma equivalent_registers_assoc[simp]:
assumes [simp]: ‹compatible F G› ‹compatible F H› ‹compatible G H›
shows ‹equivalent_registers (F;(G;H)) ((F;G);H)›
apply (rule equivalent_registersI[where I=assoc])
by auto
lemma equivalent_registers_pair_right:
assumes [simp]: ‹compatible F G›
assumes eq: ‹equivalent_registers G H›
shows ‹equivalent_registers (F;G) (F;H)›
proof -
from eq obtain I where [simp]: ‹iso_register I› and ‹G o I = H›
by (metis equivalent_registers_def)
then have *: ‹(F;G) ∘ (id ⊗⇩r I) = (F;H)›
by (auto intro!: tensor_extensionality register_comp register_preregister register_tensor_is_register
simp: register_pair_apply iso_register_is_register)
show ?thesis
apply (rule equivalent_registersI[where I=‹id ⊗⇩r I›])
using * by (auto intro!: iso_register_tensor_is_iso_register)
qed
lemma equivalent_registers_pair_left:
assumes [simp]: ‹compatible F G›
assumes eq: ‹equivalent_registers F H›
shows ‹equivalent_registers (F;G) (H;G)›
proof -
from eq obtain I where [simp]: ‹iso_register I› and ‹F o I = H›
by (metis equivalent_registers_def)
then have *: ‹(F;G) ∘ (I ⊗⇩r id) = (H;G)›
by (auto intro!: tensor_extensionality register_comp register_preregister register_tensor_is_register
simp: register_pair_apply iso_register_is_register)
show ?thesis
apply (rule equivalent_registersI[where I=‹I ⊗⇩r id›])
using * by (auto intro!: iso_register_tensor_is_iso_register)
qed
lemma equivalent_registers_comp:
assumes ‹register H›
assumes ‹equivalent_registers F G›
shows ‹equivalent_registers (H o F) (H o G)›
by (metis (no_types, lifting) assms(1) assms(2) comp_assoc equivalent_registers_def register_comp)
subsection ‹Compatibility simplification›
text ‹The simproc ‹compatibility_warn› produces helpful warnings for subgoals of the form
\<^term>‹compatible x y› that are probably unsolvable due to missing declarations of
variable compatibility facts. Same for subgoals of the form \<^term>‹register x›.›
simproc_setup "compatibility_warn" ("compatible x y" | "register x") = ‹
let val thy_string = Markup.markup (Theory.get_markup \<^theory>) (Context.theory_name \<^theory>)
in
fn m => fn ctxt => fn ct => let
val (x,y) = case Thm.term_of ct of
Const(\<^const_name>‹compatible›,_ ) $ x $ y => (x, SOME y)
| Const(\<^const_name>‹register›,_ ) $ x => (x, NONE)
val str : string lazy = Lazy.lazy (fn () => Syntax.string_of_term ctxt (Thm.term_of ct))
fun w msg = warning (msg ^ "\n(Disable these warnings with: using [[simproc del: "^thy_string^".compatibility_warn]])")
val _ = case (x,y) of
(Free(n,T), SOME (Free(n',T'))) =>
if String.isPrefix ":" n orelse String.isPrefix ":" n' then
w ("Simplification subgoal " ^ Lazy.force str ^ " contains a bound variable.\n" ^
"Try to add some assumptions that makes this goal solvable by the simplifier")
else if n=n' then (if T=T' then ()
else w ("In simplification subgoal " ^ Lazy.force str ^
", variables have same name and different types.\n" ^
"Probably something is wrong."))
else w ("Simplification subgoal " ^ Lazy.force str ^
" occurred but cannot be solved.\n" ^
"Please add assumption/fact [simp]: ‹" ^ Lazy.force str ^
"› somewhere.")
| (Free(n,T), NONE) =>
if String.isPrefix ":" n then
w ("Simplification subgoal '" ^ Lazy.force str ^ "' contains a bound variable.\n" ^
"Try to add some assumptions that makes this goal solvable by the simplifier")
else w ("Simplification subgoal " ^ Lazy.force str ^ " occurred but cannot be solved.\n" ^
"Please add assumption/fact [simp]: ‹" ^ Lazy.force str ^ "› somewhere.")
| _ => ()
in NONE end
end›
named_theorems register_attribute_rule_immediate
named_theorems register_attribute_rule
lemmas [register_attribute_rule] = conjunct1 conjunct2 iso_register_is_register iso_register_is_register[OF iso_register_inv]
lemmas [register_attribute_rule_immediate] = compatible_sym compatible_register1 compatible_register2
asm_rl[of ‹compatible _ _›] asm_rl[of ‹iso_register _›] asm_rl[of ‹register _›] iso_register_inv
text ‹The following declares an attribute ‹[register]›. When the attribute is applied to a fact
of the form \<^term>‹register F›, \<^term>‹iso_register F›, \<^term>‹compatible F G› or a conjunction of these,
then those facts are added to the simplifier together with some derived theorems
(e.g., \<^term>‹compatible F G› also adds \<^term>‹register F›).
In theory ‹Laws_Complement›, support for \<^term>‹is_unit_register F› and \<^term>‹complements F G› is
added to this attribute.›
setup ‹
let
fun add thm results =
Net.insert_term (K true) (Thm.concl_of thm, thm) results
handle Net.INSERT => results
fun try_rule f thm rule state = case SOME (rule OF [thm]) handle THM _ => NONE of
NONE => state | SOME th => f th state
fun collect (rules,rules_immediate) thm results =
results |> fold (try_rule add thm) rules_immediate |> fold (try_rule (collect (rules,rules_immediate)) thm) rules
fun declare thm context = let
val ctxt = Context.proof_of context
val rules = Named_Theorems.get ctxt @{named_theorems register_attribute_rule}
val rules_immediate = Named_Theorems.get ctxt @{named_theorems register_attribute_rule_immediate}
val thms = collect (rules,rules_immediate) thm Net.empty |> Net.entries
in Simplifier.map_ss (fn ctxt => ctxt addsimps thms) context end
in
Attrib.setup \<^binding>‹register›
(Scan.succeed (Thm.declaration_attribute declare))
"Add register-related rules to the simplifier"
end
›
subsection ‹Notation›
no_notation comp_update (infixl "*⇩u" 55)
no_notation tensor_update (infixr "⊗⇩u" 70)
bundle register_notation begin
notation register_tensor (infixr "⊗⇩r" 70)
notation register_pair ("'(_;_')")
end
bundle no_register_notation begin
no_notation register_tensor (infixr "⊗⇩r" 70)
no_notation register_pair ("'(_;_')")
end
end
Theory Laws_Complement
section ‹Generic laws about complements›
theory Laws_Complement
imports Laws Axioms_Complement
begin
notation comp_update (infixl "*⇩u" 55)
notation tensor_update (infixr "⊗⇩u" 70)
definition ‹complements F G ⟷ compatible F G ∧ iso_register (F;G)›
lemma complementsI: ‹compatible F G ⟹ iso_register (F;G) ⟹ complements F G›
using complements_def by blast
lemma complements_sym: ‹complements G F› if ‹complements F G›
proof (rule complementsI)
show [simp]: ‹compatible G F›
using compatible_sym complements_def that by blast
from that have ‹iso_register (F;G)›
by (meson complements_def)
then obtain I where [simp]: ‹register I› and ‹(F;G) o I = id› and ‹I o (F;G) = id›
using iso_register_def by blast
have ‹register (swap o I)›
using ‹register I› register_comp register_swap by blast
moreover have ‹(G;F) o (swap o I) = id›
by (simp add: ‹(F;G) ∘ I = id› rewriteL_comp_comp)
moreover have ‹(swap o I) o (G;F) = id›
by (metis (no_types, opaque_lifting) swap_swap ‹I ∘ (F;G) = id› calculation(2) comp_def eq_id_iff)
ultimately show ‹iso_register (G;F)›
using ‹compatible G F› iso_register_def pair_is_register by blast
qed
definition complement :: ‹('a::domain update ⇒ 'b::domain update) ⇒ (('a,'b) complement_domain update ⇒ 'b update)› where
‹complement F = (SOME G :: ('a, 'b) complement_domain update ⇒ 'b update. compatible F G ∧ iso_register (F;G))›
lemma register_complement[simp]: ‹register (complement F)› if ‹register F›
using complement_exists[OF that]
by (metis (no_types, lifting) compatible_def complement_def some_eq_imp)
lemma complement_is_complement:
assumes ‹register F›
shows ‹complements F (complement F)›
using complement_exists[OF assms] unfolding complements_def
by (metis (mono_tags, lifting) complement_def some_eq_imp)
lemma complement_unique:
assumes ‹complements F G›
shows ‹equivalent_registers G (complement F)›
apply (rule complement_unique[where F=F])
using assms unfolding complements_def using compatible_register1 complement_is_complement complements_def by blast+
lemma compatible_complement[simp]: ‹register F ⟹ compatible F (complement F)›
using complement_is_complement complements_def by blast
lemma complements_register_tensor:
assumes [simp]: ‹register F› ‹register G›
shows ‹complements (F ⊗⇩r G) (complement F ⊗⇩r complement G)›
proof (rule complementsI)
have sep4: ‹separating TYPE('z::domain) {(a ⊗⇩u b) ⊗⇩u (c ⊗⇩u d) |a b c d. True}›
apply (rule separating_tensor'[where A=‹{(a ⊗⇩u b) |a b. True}› and B=‹{(c ⊗⇩u d) |c d. True}›])
apply (rule separating_tensor'[where A=UNIV and B=UNIV]) apply auto[3]
apply (rule separating_tensor'[where A=UNIV and B=UNIV]) apply auto[3]
by auto
show compat: ‹compatible (F ⊗⇩r G) (complement F ⊗⇩r complement G)›
by (metis assms(1) assms(2) compatible_register_tensor complement_is_complement complements_def)
let ?reorder = ‹((Fst o Fst; Snd o Fst); (Fst o Snd; Snd o Snd))›
have [simp]: ‹register ?reorder›
by auto
have [simp]: ‹?reorder ((a ⊗⇩u b) ⊗⇩u (c ⊗⇩u d)) = ((a ⊗⇩u c) ⊗⇩u (b ⊗⇩u d))›
for a::‹'t::domain update› and b::‹'u::domain update› and c::‹'v::domain update› and d::‹'w::domain update›
by (simp add: register_pair_apply Fst_def Snd_def tensor_update_mult)
have [simp]: ‹iso_register ?reorder›
apply (rule iso_registerI[of _ ?reorder]) apply auto[2]
apply (rule register_eqI[OF sep4]) apply auto[3]
apply (rule register_eqI[OF sep4]) by auto
have ‹(F ⊗⇩r G; complement F ⊗⇩r complement G) = ((F; complement F) ⊗⇩r (G; complement G)) o ?reorder›
apply (rule register_eqI[OF sep4])
by (auto intro!: register_preregister register_comp register_tensor_is_register pair_is_register
simp: compat register_pair_apply tensor_update_mult)
moreover have ‹iso_register …›
apply (auto intro!: iso_register_comp iso_register_tensor_is_iso_register)
using assms complement_is_complement complements_def by blast+
ultimately show ‹iso_register (F ⊗⇩r G;complement F ⊗⇩r complement G)›
by simp
qed
definition is_unit_register where
‹is_unit_register U ⟷ complements U id›
lemma register_unit_register[simp]: ‹is_unit_register U ⟹ register U›
by (simp add: compatible_def complements_def is_unit_register_def)
lemma unit_register_compatible[simp]: ‹compatible U X› if ‹is_unit_register U› ‹register X›
by (metis compatible_comp_right complements_def id_comp is_unit_register_def that(1) that(2))
lemma unit_register_compatible'[simp]: ‹compatible X U› if ‹is_unit_register U› ‹register X›
using compatible_sym that(1) that(2) unit_register_compatible by blast
lemma compatible_complement_left[simp]: ‹register X ⟹ compatible (complement X) X›
using compatible_sym complement_is_complement complements_def by blast
lemma compatible_complement_right[simp]: ‹register X ⟹ compatible X (complement X)›
using complement_is_complement complements_def by blast
lemma unit_register_pair[simp]: ‹equivalent_registers X (U; X)› if [simp]: ‹is_unit_register U› ‹register X›
proof -
have ‹equivalent_registers id (U; id)›
using complements_def is_unit_register_def iso_register_equivalent_id that(1) by blast
also have ‹equivalent_registers … (U; (X; complement X))›
apply (rule equivalent_registers_pair_right)
apply (auto intro!: unit_register_compatible)
using complement_is_complement complements_def equivalent_registersI id_comp register_id that(2) by blast
also have ‹equivalent_registers … ((U; X); complement X)›
apply (rule equivalent_registers_assoc)
by auto
finally have ‹complements (U; X) (complement X)›
by (auto simp: equivalent_registers_def complements_def)
moreover have ‹equivalent_registers (X; complement X) id›
by (metis complement_is_complement complements_def equivalent_registers_def iso_register_def that)
ultimately show ?thesis
by (meson complement_unique complement_is_complement complements_sym equivalent_registers_sym equivalent_registers_trans that)
qed
lemma unit_register_compose_left:
assumes [simp]: ‹is_unit_register U›
assumes [simp]: ‹register A›
shows ‹is_unit_register (A o U)›
proof -
have ‹compatible (A o U) (A; complement A)›
apply (auto intro!: compatible3')
by (metis assms(1) assms(2) comp_id compatible_comp_inner complements_def is_unit_register_def)
then have compat[simp]: ‹compatible (A o U) id›
by (metis assms(2) compatible_comp_right complement_is_complement complements_def iso_register_def)
have ‹equivalent_registers (A o U; id) (A o U; (A; complement A))›
apply (auto intro!: equivalent_registers_pair_right)
using assms(2) complement_is_complement complements_def equivalent_registers_def id_comp register_id by blast
also have ‹equivalent_registers … ((A o U; A o id); complement A)›
apply auto
by (metis (no_types, opaque_lifting) compat assms(1) assms(2) compatible_comp_left compatible_def compatible_register1 complement_is_complement complements_def equivalent_registers_assoc id_apply register_unit_register)
also have ‹equivalent_registers … (A o (U; id); complement A)›
by (metis (no_types, opaque_lifting) assms(1) assms(2) calculation complements_def equivalent_registers_sym equivalent_registers_trans is_unit_register_def register_comp_pair)
also have ‹equivalent_registers … (A o id; complement A)›
apply (intro equivalent_registers_pair_left equivalent_registers_comp)
apply (auto simp: assms)
using assms(1) equivalent_registers_sym register_id unit_register_pair by blast
also have ‹equivalent_registers … id›
by (metis assms(2) comp_id complement_is_complement complements_def equivalent_registers_def iso_register_inv iso_register_inv_comp2 pair_is_register)
finally show ?thesis
using compat complementsI equivalent_registers_sym is_unit_register_def iso_register_equivalent_id by blast
qed
lemma unit_register_compose_right:
assumes [simp]: ‹is_unit_register U›
assumes [simp]: ‹iso_register A›
shows ‹is_unit_register (U o A)›
proof (unfold is_unit_register_def, rule complementsI)
show ‹compatible (U ∘ A) id›
by (simp add: iso_register_is_register)
have 1: ‹iso_register ((U;id) ∘ A ⊗⇩r id)›
by (meson assms(1) assms(2) complements_def is_unit_register_def iso_register_comp iso_register_id iso_register_tensor_is_iso_register)
have 2: ‹id ∘ ((U;id) ∘ A ⊗⇩r id) = (U ∘ A;id)›
by (metis assms(1) assms(2) complements_def fun.map_id is_unit_register_def iso_register_id iso_register_is_register pair_o_tensor)
show ‹iso_register (U ∘ A;id)›
using 1 2 by auto
qed
lemma unit_register_unique:
assumes ‹is_unit_register F›
assumes ‹is_unit_register G›
shows ‹equivalent_registers F G›
proof -
have ‹complements F id› ‹complements G id›
using assms by (metis complements_def equivalent_registers_def id_comp is_unit_register_def)+
then show ?thesis
by (meson complement_unique complements_sym equivalent_registers_sym equivalent_registers_trans)
qed
lemma unit_register_domains_isomorphic:
fixes F :: ‹'a::domain update ⇒ 'c::domain update›
fixes G :: ‹'b::domain update ⇒ 'd::domain update›
assumes ‹is_unit_register F›
assumes ‹is_unit_register G›
shows ‹∃I :: 'a update ⇒ 'b update. iso_register I›
proof -
have ‹is_unit_register ((λd. tensor_update id_update d) o G)›
by (simp add: assms(2) unit_register_compose_left)
moreover have ‹is_unit_register ((λc. tensor_update c id_update) o F)›
using assms(1) register_tensor_left unit_register_compose_left by blast
ultimately have ‹equivalent_registers ((λd. tensor_update id_update d) o G) ((λc. tensor_update c id_update) o F)›
using unit_register_unique by blast
then show ?thesis
unfolding equivalent_registers_def by auto
qed
lemma id_complement_is_unit_register[simp]: ‹is_unit_register (complement id)›
by (metis is_unit_register_def complement_is_complement complements_def complements_sym equivalent_registers_def id_comp register_id)
type_synonym unit_register_domain = ‹(some_domain, some_domain) complement_domain›
definition unit_register :: ‹unit_register_domain update ⇒ 'a::domain update› where ‹unit_register = (SOME U. is_unit_register U)›
lemma unit_register_is_unit_register[simp]: ‹is_unit_register (unit_register :: unit_register_domain update ⇒ 'a::domain update)›
proof -
let ?U0 = ‹complement id :: unit_register_domain update ⇒ some_domain update›
let ?U1 = ‹complement id :: ('a, 'a) complement_domain update ⇒ 'a update›
have ‹is_unit_register ?U0› ‹is_unit_register ?U1›
by auto
then obtain I :: ‹unit_register_domain update ⇒ ('a, 'a) complement_domain update› where ‹iso_register I›
apply atomize_elim by (rule unit_register_domains_isomorphic)
with ‹is_unit_register ?U1› have ‹is_unit_register (?U1 o I)›
by (rule unit_register_compose_right)
then show ?thesis
by (metis someI_ex unit_register_def)
qed
lemma unit_register_domain_tensor_unit:
fixes U :: ‹'a::domain update ⇒ _›
assumes ‹is_unit_register U›
shows ‹∃I :: 'b::domain update ⇒ ('a*'b) update. iso_register I›
proof -
have ‹equivalent_registers (id :: 'b update ⇒ _) (complement id; id)›
using id_complement_is_unit_register iso_register_equivalent_id register_id unit_register_pair by blast
then obtain J :: ‹'b update ⇒ ((('b, 'b) complement_domain * 'b) update)› where ‹iso_register J›
using equivalent_registers_def iso_register_inv by blast
moreover obtain K :: ‹('b, 'b) complement_domain update ⇒ 'a update› where ‹iso_register K›
using assms id_complement_is_unit_register unit_register_domains_isomorphic by blast
ultimately have ‹iso_register ((K ⊗⇩r id) o J)›
by auto
then show ?thesis
by auto
qed
lemma compatible_complement_pair1:
assumes ‹compatible F G›
shows ‹compatible F (complement (F;G))›
by (metis assms compatible_comp_left compatible_complement_right pair_is_register register_Fst register_pair_Fst)
lemma compatible_complement_pair2:
assumes [simp]: ‹compatible F G›
shows ‹compatible G (complement (F;G))›
proof -
have ‹compatible (F;G) (complement (F;G))›
by simp
then have ‹compatible ((F;G) o Snd) (complement (F;G))›
by auto
then show ?thesis
by (auto simp: register_pair_Snd)
qed
lemma equivalent_complements:
assumes ‹complements F G›
assumes ‹equivalent_registers G G'›
shows ‹complements F G'›
apply (rule complementsI)
apply (metis assms(1) assms(2) compatible_comp_right complements_def equivalent_registers_def iso_register_is_register)
by (metis assms(1) assms(2) complements_def equivalent_registers_def equivalent_registers_pair_right iso_register_comp)
lemma complements_complement_pair:
assumes [simp]: ‹compatible F G›
shows ‹complements F (G; complement (F;G))›
proof (rule complementsI)
have ‹equivalent_registers (F; (G; complement (F;G))) ((F;G); complement (F;G))›
apply (rule equivalent_registers_assoc)
by (auto simp add: compatible_complement_pair1 compatible_complement_pair2)
also have ‹equivalent_registers … id›
by (meson assms complement_is_complement complements_def equivalent_registers_sym iso_register_equivalent_id pair_is_register)
finally show ‹iso_register (F;(G;complement (F;G)))›
using equivalent_registers_sym iso_register_equivalent_id by blast
show ‹compatible F (G;complement (F;G))›
using assms compatible3' compatible_complement_pair1 compatible_complement_pair2 by blast
qed
lemma equivalent_registers_complement:
assumes ‹equivalent_registers F G›
shows ‹equivalent_registers (complement F) (complement G)›
proof -
have ‹complements F (complement F)›
using assms complement_is_complement equivalent_registers_register_left by blast
with assms have ‹complements G (complement F)›
by (meson complements_sym equivalent_complements)
then show ?thesis
by (rule complement_unique)
qed
lemma complements_complement_pair':
assumes [simp]: ‹compatible F G›
shows ‹complements G (F; complement (F;G))›
proof -
have ‹equivalent_registers (F;G) (G;F)›
apply (rule equivalent_registersI[where I=swap])
by auto
then have ‹equivalent_registers (complement (F;G)) (complement (G;F))›
by (rule equivalent_registers_complement)
then have ‹equivalent_registers (F; (complement (F;G))) (F; (complement (G;F)))›
apply (rule equivalent_registers_pair_right[rotated])
using assms compatible_complement_pair1 by blast
moreover have ‹complements G (F; complement (G;F))›
apply (rule complements_complement_pair)
using assms compatible_sym by blast
ultimately show ?thesis
by (meson equivalent_complements equivalent_registers_sym)
qed
lemma complements_chain:
assumes [simp]: ‹register F› ‹register G›
shows ‹complements (F o G) (complement F; F o complement G)›
proof (rule complementsI)
show ‹compatible (F o G) (complement F; F o complement G)›
by auto
have ‹equivalent_registers (F ∘ G;(complement F;F ∘ complement G)) (F ∘ G;(F ∘ complement G;complement F))›
apply (rule equivalent_registersI[where I=‹id ⊗⇩r swap›])
by (auto intro!: iso_register_tensor_is_iso_register simp: pair_o_tensor)
also have ‹equivalent_registers … ((F ∘ G;F ∘ complement G);complement F)›
apply (rule equivalent_registersI[where I=assoc])
by (auto intro!: iso_register_tensor_is_iso_register simp: pair_o_tensor)
also have ‹equivalent_registers … (F o (G; complement G);complement F)›
by (metis (no_types, lifting) assms(1) assms(2) calculation compatible_complement_right
equivalent_registers_sym equivalent_registers_trans register_comp_pair)
also have ‹equivalent_registers … (F o id;complement F)›
apply (rule equivalent_registers_pair_left, simp)
apply (rule equivalent_registers_comp, simp)
by (metis assms(2) complement_is_complement complements_def equivalent_registers_def iso_register_def)
also have ‹equivalent_registers … id›
by (metis assms(1) comp_id complement_is_complement complements_def equivalent_registers_def iso_register_def)
finally show ‹iso_register (F ∘ G;(complement F;F ∘ complement G))›
using equivalent_registers_sym iso_register_equivalent_id by blast
qed
lemma complements_Fst_Snd[simp]: ‹complements Fst Snd›
by (auto intro!: complementsI simp: pair_Fst_Snd)
lemma complements_Snd_Fst[simp]: ‹complements Snd Fst›
by (auto intro!: complementsI simp flip: swap_def)
lemma compatible_unit_register[simp]: ‹register F ⟹ compatible F unit_register›
using compatible_sym unit_register_compatible unit_register_is_unit_register by blast
lemma complements_id_unit_register[simp]: ‹complements id unit_register›
using complements_sym is_unit_register_def unit_register_is_unit_register by blast
lemma complements_iso_unit_register: ‹iso_register I ⟹ is_unit_register U ⟹ complements I U›
using complements_sym equivalent_complements is_unit_register_def iso_register_equivalent_id by blast
lemma iso_register_complement_is_unit_register[simp]:
assumes ‹iso_register F›
shows ‹is_unit_register (complement F)›
by (meson assms complement_is_complement complements_sym equivalent_complements equivalent_registers_sym is_unit_register_def iso_register_equivalent_id iso_register_is_register)
text ‹Adding support for \<^term>‹is_unit_register F› and \<^term>‹complements F G› to the [@{attribute register}] attribute›
lemmas [register_attribute_rule] = is_unit_register_def[THEN iffD1] complements_def[THEN iffD1]
lemmas [register_attribute_rule_immediate] = asm_rl[of ‹is_unit_register _›]
no_notation comp_update (infixl "*⇩u" 55)
no_notation tensor_update (infixr "⊗⇩u" 70)
end
Theory Axioms_Classical
section ‹Classical instantiation of registerss›
theory Axioms_Classical
imports Main
begin
type_synonym 'a update = ‹'a ⇀ 'a›
lemma id_update_left: "Some ∘⇩m a = a"
by (auto intro!: ext simp add: map_comp_def option.case_eq_if)
lemma id_update_right: "a ∘⇩m Some = a"
by auto
lemma comp_update_assoc: "(a ∘⇩m b) ∘⇩m c = a ∘⇩m (b ∘⇩m c)"
by (auto intro!: ext simp add: map_comp_def option.case_eq_if)
type_synonym ('a,'b) preregister = ‹'a update ⇒ 'b update›
definition preregister :: ‹('a,'b) preregister ⇒ bool› where
‹preregister F ⟷ (∃g s. ∀a m. F a m = (case a (g m) of None ⇒ None | Some x ⇒ s x m))›
lemma id_preregister: ‹preregister id›
unfolding preregister_def
apply (rule exI[of _ ‹λm. m›])
apply (rule exI[of _ ‹λa m. Some a›])
by (simp add: option.case_eq_if)
lemma preregister_mult_right: ‹preregister (λa. a ∘⇩m z)›
unfolding preregister_def
apply (rule exI[of _ ‹λm. the (z m)›])
apply (rule exI[of _ ‹λx m. case z m of None ⇒ None | _ ⇒ Some x›])
by (auto simp add: option.case_eq_if)
lemma preregister_mult_left: ‹preregister (λa. z ∘⇩m a)›
unfolding preregister_def
apply (rule exI[of _ ‹λm. m›])
apply (rule exI[of _ ‹λx m. z x›])
by (auto simp add: option.case_eq_if)
lemma comp_preregister: "preregister (G ∘ F)" if "preregister F" and ‹preregister G›
proof -
from ‹preregister F›
obtain sF gF where F: ‹F a m = (case a (gF m) of None ⇒ None | Some x ⇒ sF x m)› for a m
using preregister_def by blast
from ‹preregister G›
obtain sG gG where G: ‹G a m = (case a (gG m) of None ⇒ None | Some x ⇒ sG x m)› for a m
using preregister_def by blast
define s g where ‹s a m = (case sF a (gG m) of None ⇒ None | Some x ⇒ sG x m)›
and ‹g m = gF (gG m)› for a m
have ‹(G ∘ F) a m = (case a (g m) of None ⇒ None | Some x ⇒ s x m)› for a m
unfolding F G s_def g_def
by (auto simp add: option.case_eq_if)
then show "preregister (G ∘ F)"
using preregister_def by blast
qed
definition tensor_update :: ‹'a update ⇒ 'b update ⇒ ('a×'b) update› where
‹tensor_update a b m = (case a (fst m) of None ⇒ None | Some x ⇒ (case b (snd m) of None ⇒ None | Some y ⇒ Some (x,y)))›
lemma tensor_update_mult: ‹tensor_update a c ∘⇩m tensor_update b d = tensor_update (a ∘⇩m b) (c ∘⇩m d)›
by (auto intro!: ext simp add: map_comp_def option.case_eq_if tensor_update_def)
definition update1 :: ‹'a ⇒ 'a ⇒ 'a update› where
‹update1 x y m = (if m=x then Some y else None)›
lemma update1_extensionality:
assumes ‹preregister F›
assumes ‹preregister G›
assumes FGeq: ‹⋀x y. F (update1 x y) = G (update1 x y)›
shows "F = G"
proof (rule ccontr)
assume neq: ‹F ≠ G›
then obtain z m where neq': ‹F z m ≠ G z m›
apply atomize_elim by auto
obtain gF sF where gsF: ‹F z m = (case z (gF m) of None ⇒ None | Some x ⇒ sF x m)› for z m
using ‹preregister F› preregister_def by blast
obtain gG sG where gsG: ‹G z m = (case z (gG m) of None ⇒ None | Some x ⇒ sG x m)› for z m
using ‹preregister G› preregister_def by blast
consider (abeq) x where ‹z (gF m) = Some x› ‹z (gG m) = Some x› ‹gF m = gG m›
| (abnone) ‹z (gG m) = None› ‹z (gF m) = None›
| (neqF) x where ‹gF m ≠ gG m› ‹F z m = Some x›
| (neqG) y where ‹gF m ≠ gG m› ‹G z m = Some y›
| (neqNone) ‹gF m ≠ gG m› ‹F z m = None› ‹G z m = None›
apply atomize_elim by (metis option.exhaust_sel)
then show False
proof cases
case (abeq x)
then have ‹F z m = sF x m› and ‹G z m = sG x m›
by (simp_all add: gsF gsG)
moreover have ‹F (update1 (gF m) x) m = sF x m›
by (simp add: gsF update1_def)
moreover have ‹G (update1 (gF m) x) m = sG x m›
by (simp add: abeq gsG update1_def)
ultimately show False
using FGeq neq' by force
next
case abnone
then show False
using gsF gsG neq' by force
next
case neqF
moreover
have ‹F (update1 (gF m) (the (z (gF m)))) m = F z m›
by (metis gsF neqF(2) option.case_eq_if option.simps(3) option.simps(5) update1_def)
moreover have ‹G (update1 (gF m) (the (z (gF m)))) m = None›
by (metis gsG neqF(1) option.case_eq_if update1_def)
ultimately show False
using FGeq by force
next
case neqG
moreover
have ‹G (update1 (gG m) (the (z (gG m)))) m = G z m›
by (metis gsG neqG(2) option.case_eq_if option.distinct(1) option.simps(5) update1_def)
moreover have ‹F (update1 (gG m) (the (z (gG m)))) m = None›
by (simp add: gsF neqG(1) update1_def)
ultimately show False
using FGeq by force
next
case neqNone
with neq' show False
by fastforce
qed
qed
lemma tensor_extensionality:
assumes ‹preregister F›
assumes ‹preregister G›
assumes FGeq: ‹⋀a b. F (tensor_update a b) = G (tensor_update a b)›
shows "F = G"
proof -
have ‹F (update1 x y) = G (update1 x y)› for x y
using FGeq[of ‹update1 (fst x) (fst y)› ‹update1 (snd x) (snd y)›]
apply (auto intro!:ext simp: tensor_update_def[abs_def] update1_def[abs_def])
by (smt (z3) assms(1) assms(2) option.case(2) option.case_eq_if preregister_def prod.collapse)
with assms(1,2) show "F = G"
by (rule update1_extensionality)
qed
definition "valid_getter_setter g s ⟷
(∀b. b = s (g b) b) ∧ (∀a b. g (s a b) = a) ∧ (∀a a' b. s a (s a' b) = s a b)"
definition ‹register_from_getter_setter g s a m = (case a (g m) of None ⇒ None | Some x ⇒ Some (s x m))›
definition ‹register_apply F a = the o F (Some o a)›
definition ‹setter F a m = register_apply F (λ_. a) m› for F :: ‹'a update ⇒ 'b update›
definition ‹getter F m = (THE x. setter F x m = m)› for F :: ‹'a update ⇒ 'b update›
lemma
assumes ‹valid_getter_setter g s›
shows getter_of_register_from_getter_setter[simp]: ‹getter (register_from_getter_setter g s) = g›
and setter_of_register_from_getter_setter[simp]: ‹setter (register_from_getter_setter g s) = s›
proof -
define g' s' where ‹g' = getter (register_from_getter_setter g s)›
and ‹s' = setter (register_from_getter_setter g s)›
show ‹s' = s›
by (auto intro!:ext simp: s'_def setter_def register_apply_def register_from_getter_setter_def)
moreover show ‹g' = g›
proof (rule ext, rename_tac m)
fix m
have ‹g' m = (THE x. s x m = m)›
by (auto intro!:ext simp: g'_def s'_def[symmetric] ‹s'=s› getter_def register_apply_def register_from_getter_setter_def)
moreover have ‹s (g m) m = m›
by (metis assms valid_getter_setter_def)
moreover have ‹x = x'› if ‹s x m = m› ‹s x' m = m› for x x'
by (metis assms that(1) that(2) valid_getter_setter_def)
ultimately show ‹g' m = g m›
by (simp add: Uniq_def the1_equality')
qed
qed
definition register :: ‹('a,'b) preregister ⇒ bool› where
‹register F ⟷ (∃g s. F = register_from_getter_setter g s ∧ valid_getter_setter g s)›
lemma register_of_id: ‹register F ⟹ F Some = Some›
by (auto simp add: register_def valid_getter_setter_def register_from_getter_setter_def)
lemma register_id: ‹register id›
unfolding register_def
apply (rule exI[of _ id], rule exI[of _ ‹λa m. a›])
by (auto intro!: ext simp: option.case_eq_if register_from_getter_setter_def valid_getter_setter_def)
lemma register_tensor_left: ‹register (λa. tensor_update a Some)›
apply (auto simp: register_def)
apply (rule exI[of _ fst])
apply (rule exI[of _ ‹λx' (x,y). (x',y)›])
by (auto intro!: ext simp add: tensor_update_def valid_getter_setter_def register_from_getter_setter_def option.case_eq_if)
lemma register_tensor_right: ‹register (λa. tensor_update Some a)›
apply (auto simp: register_def)
apply (rule exI[of _ snd])
apply (rule exI[of _ ‹λy' (x,y). (x,y')›])
by (auto intro!: ext simp add: tensor_update_def valid_getter_setter_def register_from_getter_setter_def option.case_eq_if)
lemma register_preregister: "preregister F" if ‹register F›
proof -
from ‹register F›
obtain s g where F: ‹F a m = (case a (g m) of None ⇒ None | Some x ⇒ Some (s x m))› for a m
unfolding register_from_getter_setter_def register_def by blast
show ?thesis
unfolding preregister_def
apply (rule exI[of _ g])
apply (rule exI[of _ ‹λx m. Some (s x m)›])
using F by simp
qed
lemma register_comp: "register (G ∘ F)" if ‹register F› and ‹register G›
for F :: "('a,'b) preregister" and G :: "('b,'c) preregister"
proof -
from ‹register F›
obtain sF gF where F: ‹F a m = (case a (gF m) of None ⇒ None | Some x ⇒ Some (sF x m))›
and validF: ‹valid_getter_setter gF sF› for a m
unfolding register_def register_from_getter_setter_def by blast
from ‹register G›
obtain sG gG where G: ‹G a m = (case a (gG m) of None ⇒ None | Some x ⇒ Some (sG x m))›
and validG: ‹valid_getter_setter gG sG› for a m
unfolding register_def register_from_getter_setter_def by blast
define s g where ‹s a m = sG (sF a (gG m)) m› and ‹g m = gF (gG m)› for a m
have ‹(G ∘ F) a m = (case a (g m) of None ⇒ None | Some x ⇒ Some (s x m))› for a m
by (auto simp add: option.case_eq_if F G s_def g_def)
moreover have ‹valid_getter_setter g s›
using validF validG by (auto simp: valid_getter_setter_def s_def g_def)
ultimately show "register (G ∘ F)"
unfolding register_def register_from_getter_setter_def by blast
qed
lemma register_mult: "register F ⟹ F a ∘⇩m F b = F (a ∘⇩m b)"
by (auto intro!: ext simp: register_def register_from_getter_setter_def[abs_def] valid_getter_setter_def map_comp_def option.case_eq_if)
definition register_pair ::
‹('a update ⇒ 'c update) ⇒ ('b update ⇒ 'c update) ⇒ (('a×'b) update ⇒ 'c update)› where
‹register_pair F G =
register_from_getter_setter (λm. (getter F m, getter G m)) (λ(a,b) m. setter F a (setter G b m))›
lemma compatible_setter:
assumes [simp]: ‹register F› ‹register G›
assumes compat: ‹⋀a b. F a ∘⇩m G b = G b ∘⇩m F a›
shows ‹setter F x o setter G y = setter G y o setter F x›
using compat apply (auto intro!: ext simp: setter_def register_apply_def o_def map_comp_def)
by (smt (verit, best) assms(1) assms(2) option.case_eq_if option.distinct(1) register_def register_from_getter_setter_def)
lemma register_pair_apply:
assumes [simp]: ‹register F› ‹register G›
assumes ‹⋀a b. F a ∘⇩m G b = G b ∘⇩m F a›
shows ‹(register_pair F G) (tensor_update a b) = F a ∘⇩m G b›
proof -
have validF: ‹valid_getter_setter (getter F) (setter F)› and validG: ‹valid_getter_setter (getter G) (setter G)›
by (metis assms getter_of_register_from_getter_setter register_def setter_of_register_from_getter_setter)+
then have F: ‹F = register_from_getter_setter (getter F) (setter F)› and G: ‹G = register_from_getter_setter (getter G) (setter G)›
by (metis assms getter_of_register_from_getter_setter register_def setter_of_register_from_getter_setter)+
have gFsG: ‹getter F (setter G y m) = getter F m› for y m
proof -
have ‹getter F (setter G y m) = getter F (setter G y (setter F (getter F m) m))›
using validF by (metis valid_getter_setter_def)
also have ‹… = getter F (setter F (getter F m) (setter G y m))›
by (metis (mono_tags, lifting) assms(1) assms(2) assms(3) comp_eq_dest_lhs compatible_setter)
also have ‹… = getter F m›
by (metis validF valid_getter_setter_def)
finally show ?thesis by -
qed
show ?thesis
apply (subst (2) F, subst (2) G)
by (auto intro!:ext simp: register_pair_def tensor_update_def map_comp_def option.case_eq_if
register_from_getter_setter_def gFsG)
qed
lemma register_pair_is_register:
fixes F :: ‹'a update ⇒ 'c update› and G
assumes [simp]: ‹register F› and [simp]: ‹register G›
assumes compat: ‹⋀a b. F a ∘⇩m G b = G b ∘⇩m F a›
shows ‹register (register_pair F G)›
proof -
have validF: ‹valid_getter_setter (getter F) (setter F)› and validG: ‹valid_getter_setter (getter G) (setter G)›
by (metis assms getter_of_register_from_getter_setter register_def setter_of_register_from_getter_setter)+
then have ‹valid_getter_setter (λm. (getter F m, getter G m)) (λ(a, b) m. setter F a (setter G b m))›
apply (simp add: valid_getter_setter_def)
by (metis (mono_tags, lifting) assms comp_eq_dest_lhs compat compatible_setter)
then show ?thesis
by (auto simp: register_pair_def register_def)
qed
end
Theory Laws_Classical
section ‹Generic laws about registers, instantiated classically›
theory Laws_Classical
imports Axioms_Classical
begin
text ‹This notation is only used inside this file›
notation map_comp (infixl "*⇩u" 55)
notation tensor_update (infixr "⊗⇩u" 70)
notation register_pair ("'(_;_')")
subsection ‹Elementary facts›
declare id_preregister[simp]
declare id_update_left[simp]
declare id_update_right[simp]
declare register_preregister[simp]
declare register_comp[simp]
declare register_of_id[simp]
declare register_tensor_left[simp]
declare register_tensor_right[simp]
declare preregister_mult_right[simp]
declare preregister_mult_left[simp]
declare register_id[simp]
subsection ‹Preregisters›
lemma preregister_tensor_left[simp]: ‹preregister (λb::'b::type update. tensor_update a b)›
for a :: ‹'a::type update›
proof -
have ‹preregister ((λb1::('a×'b) update. (a ⊗⇩u Some) *⇩u b1) o (λb. tensor_update Some b))›
by (rule comp_preregister; simp)
then show ?thesis
by (simp add: o_def tensor_update_mult)
qed
lemma preregister_tensor_right[simp]: ‹preregister (λa::'a::type update. tensor_update a b)›
for b :: ‹'b::type update›
proof -
have ‹preregister ((λa1::('a×'b) update. (Some ⊗⇩u b) *⇩u a1) o (λa. tensor_update a Some))›
by (rule comp_preregister, simp_all)
then show ?thesis
by (simp add: o_def tensor_update_mult)
qed
subsection ‹Registers›
lemma id_update_tensor_register[simp]:
assumes ‹register F›
shows ‹register (λa::'a::type update. Some ⊗⇩u F a)›
using assms apply (rule register_comp[unfolded o_def])
by simp
lemma register_tensor_id_update[simp]:
assumes ‹register F›
shows ‹register (λa::'a::type update. F a ⊗⇩u Some)›
using assms apply (rule register_comp[unfolded o_def])
by simp
subsection ‹Tensor product of registers›
definition register_tensor (infixr "⊗⇩r" 70) where
"register_tensor F G = register_pair (λa. tensor_update (F a) Some) (λb. tensor_update Some (G b))"
lemma register_tensor_is_register:
fixes F :: "'a::type update ⇒ 'b::type update" and G :: "'c::type update ⇒ 'd::type update"
shows "register F ⟹ register G ⟹ register (F ⊗⇩r G)"
unfolding register_tensor_def
apply (rule register_pair_is_register)
by (simp_all add: tensor_update_mult)
lemma register_tensor_apply[simp]:
fixes F :: "'a::type update ⇒ 'b::type update" and G :: "'c::type update ⇒ 'd::type update"
assumes ‹register F› and ‹register G›
shows "(F ⊗⇩r G) (a ⊗⇩u b) = F a ⊗⇩u G b"
unfolding register_tensor_def
apply (subst register_pair_apply)
unfolding register_tensor_def
by (simp_all add: assms tensor_update_mult)
definition "separating (_::'b::type itself) A ⟷
(∀F G :: 'a::type update ⇒ 'b update. preregister F ⟶ preregister G ⟶ (∀x∈A. F x = G x) ⟶ F = G)"
lemma separating_UNIV[simp]: ‹separating TYPE(_) UNIV›
unfolding separating_def by auto
lemma separating_mono: ‹A ⊆ B ⟹ separating TYPE('a::type) A ⟹ separating TYPE('a) B›
unfolding separating_def by (meson in_mono)
lemma register_eqI: ‹separating TYPE('b::type) A ⟹ preregister F ⟹ preregister G ⟹ (⋀x. x∈A ⟹ F x = G x) ⟹ F = (G::_ ⇒ 'b update)›
unfolding separating_def by auto
lemma separating_tensor:
fixes A :: ‹'a::type update set› and B :: ‹'b::type update set›
assumes [simp]: ‹separating TYPE('c::type) A›
assumes [simp]: ‹separating TYPE('c) B›
shows ‹separating TYPE('c) {a ⊗⇩u b | a b. a∈A ∧ b∈B}›
proof (unfold separating_def, intro allI impI)
fix F G :: ‹('a×'b) update ⇒ 'c update›
assume [simp]: ‹preregister F› ‹preregister G›
have [simp]: ‹preregister (λx. F (a ⊗⇩u x))› for a
using _ ‹preregister F› apply (rule comp_preregister[unfolded o_def])
by simp
have [simp]: ‹preregister (λx. G (a ⊗⇩u x))› for a
using _ ‹preregister G› apply (rule comp_preregister[unfolded o_def])
by simp
have [simp]: ‹preregister (λx. F (x ⊗⇩u b))› for b
using _ ‹preregister F› apply (rule comp_preregister[unfolded o_def])
by simp
have [simp]: ‹preregister (λx. G (x ⊗⇩u b))› for b
using _ ‹preregister G› apply (rule comp_preregister[unfolded o_def])
by simp
assume ‹∀x∈{a ⊗⇩u b |a b. a∈A ∧ b∈B}. F x = G x›
then have EQ: ‹F (a ⊗⇩u b) = G (a ⊗⇩u b)› if ‹a ∈ A› and ‹b ∈ B› for a b
using that by auto
then have ‹F (a ⊗⇩u b) = G (a ⊗⇩u b)› if ‹a ∈ A› for a b
apply (rule register_eqI[where A=B, THEN fun_cong, where x=b, rotated -1])
using that by auto
then have ‹F (a ⊗⇩u b) = G (a ⊗⇩u b)› for a b
apply (rule register_eqI[where A=A, THEN fun_cong, where x=a, rotated -1])
by auto
then show "F = G"
apply (rule tensor_extensionality[rotated -1])
by auto
qed
lemma register_tensor_distrib:
assumes [simp]: ‹register F› ‹register G› ‹register H› ‹register L›
shows ‹(F ⊗⇩r G) o (H ⊗⇩r L) = (F o H) ⊗⇩r (G o L)›
apply (rule tensor_extensionality)
by (auto intro!: register_comp register_preregister register_tensor_is_register)
text ‹The following is easier to apply using the @{method rule}-method than @{thm [source] separating_tensor}›
lemma separating_tensor':
fixes A :: ‹'a::type update set› and B :: ‹'b::type update set›
assumes ‹separating TYPE('c::type) A›
assumes ‹separating TYPE('c) B›
assumes ‹C = {a ⊗⇩u b | a b. a∈A ∧ b∈B}›
shows ‹separating TYPE('c) C›
using assms
by (simp add: separating_tensor)
lemma tensor_extensionality3:
fixes F G :: ‹('a::type×'b::type×'c::type) update ⇒ 'd::type update›
assumes [simp]: ‹register F› ‹register G›
assumes "⋀f g h. F (f ⊗⇩u g ⊗⇩u h) = G (f ⊗⇩u g ⊗⇩u h)"
shows "F = G"
proof (rule register_eqI[where A=‹{a⊗⇩ub⊗⇩uc| a b c. True}›])
have ‹separating TYPE('d) {b ⊗⇩u c |b c. True}›
apply (rule separating_tensor'[where A=UNIV and B=UNIV])
by auto
then show ‹separating TYPE('d) {a ⊗⇩u b ⊗⇩u c |a b c. True}›
apply (rule_tac separating_tensor'[where A=UNIV and B=‹{b⊗⇩uc| b c. True}›])
by auto
show ‹preregister F› ‹preregister G› by auto
show ‹x ∈ {a ⊗⇩u b ⊗⇩u c |a b c. True} ⟹ F x = G x› for x
using assms(3) by auto
qed
lemma tensor_extensionality3':
fixes F G :: ‹(('a::type×'b::type)×'c::type) update ⇒ 'd::type update›
assumes [simp]: ‹register F› ‹register G›
assumes "⋀f g h. F ((f ⊗⇩u g) ⊗⇩u h) = G ((f ⊗⇩u g) ⊗⇩u h)"
shows "F = G"
proof (rule register_eqI[where A=‹{(a⊗⇩ub)⊗⇩uc| a b c. True}›])
have ‹separating TYPE('d) {a ⊗⇩u b | a b. True}›
apply (rule separating_tensor'[where A=UNIV and B=UNIV])
by auto
then show ‹separating TYPE('d) {(a ⊗⇩u b) ⊗⇩u c |a b c. True}›
apply (rule_tac separating_tensor'[where B=UNIV and A=‹{a⊗⇩ub| a b. True}›])
by auto
show ‹preregister F› ‹preregister G› by auto
show ‹x ∈ {(a ⊗⇩u b) ⊗⇩u c |a b c. True} ⟹ F x = G x› for x
using assms(3) by auto
qed
lemma register_tensor_id[simp]: ‹id ⊗⇩r id = id›
apply (rule tensor_extensionality)
by (auto simp add: register_tensor_is_register)
subsection ‹Pairs and compatibility›
definition compatible :: ‹('a::type update ⇒ 'c::type update)
⇒ ('b::type update ⇒ 'c update) ⇒ bool› where
‹compatible F G ⟷ register F ∧ register G ∧ (∀a b. F a *⇩u G b = G b *⇩u F a)›
lemma compatibleI:
assumes "register F" and "register G"
assumes ‹⋀a b. (F a) *⇩u (G b) = (G b) *⇩u (F a)›
shows "compatible F G"
using assms unfolding compatible_def by simp
lemma swap_registers:
assumes "compatible R S"
shows "R a *⇩u S b = S b *⇩u R a"
using assms unfolding compatible_def by metis
lemma compatible_sym: "compatible x y ⟹ compatible y x"
by (simp add: compatible_def)
lemma pair_is_register[simp]:
assumes "compatible F G"
shows "register (F; G)"
by (metis assms compatible_def register_pair_is_register)
lemma register_pair_apply:
assumes ‹compatible F G›
shows ‹(F; G) (a ⊗⇩u b) = (F a) *⇩u (G b)›
apply (rule register_pair_apply)
using assms unfolding compatible_def by metis+
lemma register_pair_apply':
assumes ‹compatible F G›
shows ‹(F; G) (a ⊗⇩u b) = (G b) *⇩u (F a)›
apply (subst register_pair_apply)
using assms by (auto simp: compatible_def intro: register_preregister)
lemma compatible_comp_left[simp]: "compatible F G ⟹ register H ⟹ compatible (F ∘ H) G"
by (simp add: compatible_def)
lemma compatible_comp_right[simp]: "compatible F G ⟹ register H ⟹ compatible F (G ∘ H)"
by (simp add: compatible_def)
lemma compatible_comp_inner[simp]:
"compatible F G ⟹ register H ⟹ compatible (H ∘ F) (H ∘ G)"
by (smt (verit, best) comp_apply compatible_def register_comp register_mult)
lemma compatible_register1: ‹compatible F G ⟹ register F›
by (simp add: compatible_def)
lemma compatible_register2: ‹compatible F G ⟹ register G›
by (simp add: compatible_def)
lemma pair_o_tensor:
assumes "compatible A B" and [simp]: ‹register C› and [simp]: ‹register D›
shows "(A; B) o (C ⊗⇩r D) = (A o C; B o D)"
apply (rule tensor_extensionality)
using assms by (simp_all add: register_tensor_is_register register_pair_apply comp_preregister)
lemma compatible_tensor_id_update_left[simp]:
fixes F :: "'a::type update ⇒ 'c::type update" and G :: "'b::type update ⇒ 'c::type update"
assumes "compatible F G"
shows "compatible (λa. Some ⊗⇩u F a) (λa. Some ⊗⇩u G a)"
using assms apply (rule compatible_comp_inner[unfolded o_def])
by simp
lemma compatible_tensor_id_update_right[simp]:
fixes F :: "'a::type update ⇒ 'c::type update" and G :: "'b::type update ⇒ 'c::type update"
assumes "compatible F G"
shows "compatible (λa. F a ⊗⇩u Some) (λa. G a ⊗⇩u Some)"
using assms apply (rule compatible_comp_inner[unfolded o_def])
by simp
lemma compatible_tensor_id_update_rl[simp]:
assumes "register F" and "register G"
shows "compatible (λa. F a ⊗⇩u Some) (λa. Some ⊗⇩u G a)"
apply (rule compatibleI)
using assms by (auto simp: tensor_update_mult)
lemma compatible_tensor_id_update_lr[simp]:
assumes "register F" and "register G"
shows "compatible (λa. Some ⊗⇩u F a) (λa. G a ⊗⇩u Some)"
apply (rule compatibleI)
using assms by (auto simp: tensor_update_mult)
lemma register_comp_pair:
assumes [simp]: ‹register F› and [simp]: ‹compatible G H›
shows "(F o G; F o H) = F o (G; H)"
proof (rule tensor_extensionality)
show ‹preregister (F ∘ G;F ∘ H)› and ‹preregister (F ∘ (G;H))›
by simp_all
have [simp]: ‹compatible (F o G) (F o H)›
apply (rule compatible_comp_inner, simp)
by simp
then have [simp]: ‹register (F ∘ G)› ‹register (F ∘ H)›
unfolding compatible_def by auto
from assms have [simp]: ‹register G› ‹register H›
unfolding compatible_def by auto
fix a b
show ‹(F ∘ G;F ∘ H) (a ⊗⇩u b) = (F ∘ (G;H)) (a ⊗⇩u b)›
by (auto simp: register_pair_apply register_mult tensor_update_mult)
qed
lemma swap_registers_left:
assumes "compatible R S"
shows "R a *⇩u S b *⇩u c = S b *⇩u R a *⇩u c"
using assms unfolding compatible_def by metis
lemma swap_registers_right:
assumes "compatible R S"
shows "c *⇩u R a *⇩u S b = c *⇩u S b *⇩u R a"
by (metis assms comp_update_assoc compatible_def)
lemmas compatible_ac_rules = swap_registers comp_update_assoc[symmetric] swap_registers_right
subsection ‹Fst and Snd›
definition Fst where ‹Fst a = a ⊗⇩u Some›
definition Snd where ‹Snd a = Some ⊗⇩u a›
lemma register_Fst[simp]: ‹register Fst›
unfolding Fst_def by (rule register_tensor_left)
lemma register_Snd[simp]: ‹register Snd›
unfolding Snd_def by (rule register_tensor_right)
lemma compatible_Fst_Snd[simp]: ‹compatible Fst Snd›
apply (rule compatibleI, simp, simp)
by (simp add: Fst_def Snd_def tensor_update_mult)
lemmas compatible_Snd_Fst[simp] = compatible_Fst_Snd[THEN compatible_sym]
definition ‹swap = (Snd; Fst)›
lemma swap_apply[simp]: "swap (a ⊗⇩u b) = (b ⊗⇩u a)"
unfolding swap_def
by (simp add: Axioms_Classical.register_pair_apply Fst_def Snd_def tensor_update_mult)
lemma swap_o_Fst: "swap o Fst = Snd"
by (auto simp add: Fst_def Snd_def)
lemma swap_o_Snd: "swap o Snd = Fst"
by (auto simp add: Fst_def Snd_def)
lemma register_swap[simp]: ‹register swap›
by (simp add: swap_def)
lemma pair_Fst_Snd: ‹(Fst; Snd) = id›
apply (rule tensor_extensionality)
by (simp_all add: register_pair_apply Fst_def Snd_def tensor_update_mult)
lemma swap_o_swap[simp]: ‹swap o swap = id›
by (metis swap_def compatible_Snd_Fst pair_Fst_Snd register_comp_pair register_swap swap_o_Fst swap_o_Snd)
lemma swap_swap[simp]: ‹swap (swap x) = x›
by (simp add: pointfree_idE)
lemma inv_swap[simp]: ‹inv swap = swap›
by (meson inv_unique_comp swap_o_swap)
lemma register_pair_Fst:
assumes ‹compatible F G›
shows ‹(F;G) o Fst = F›
using assms by (auto intro!: ext simp: Fst_def register_pair_apply compatible_register2)
lemma register_pair_Snd:
assumes ‹compatible F G›
shows ‹(F;G) o Snd = G›
using assms by (auto intro!: ext simp: Snd_def register_pair_apply compatible_register1)
lemma register_Fst_register_Snd[simp]:
assumes ‹register F›
shows ‹(F o Fst; F o Snd) = F›
apply (rule tensor_extensionality)
using assms by (auto simp: register_pair_apply Fst_def Snd_def register_mult tensor_update_mult)
lemma register_Snd_register_Fst[simp]:
assumes ‹register F›
shows ‹(F o Snd; F o Fst) = F o swap›
apply (rule tensor_extensionality)
using assms by (auto simp: register_pair_apply Fst_def Snd_def register_mult tensor_update_mult)
lemma compatible3[simp]:
assumes [simp]: "compatible F G" and "compatible G H" and "compatible F H"
shows "compatible (F; G) H"
proof (rule compatibleI)
have [simp]: ‹register F› ‹register G› ‹register H›
using assms compatible_def by auto
then have [simp]: ‹preregister F› ‹preregister G› ‹preregister H›
using register_preregister by blast+
have [simp]: ‹preregister (λa. (F;G) a *⇩u z)› for z
apply (rule comp_preregister[unfolded o_def, of ‹(F;G)›])
by simp_all
have [simp]: ‹preregister (λa. z *⇩u (F;G) a)› for z
apply (rule comp_preregister[unfolded o_def, of ‹(F;G)›])
by simp_all
have "(F; G) (f ⊗⇩u g) *⇩u H h = H h *⇩u (F; G) (f ⊗⇩u g)" for f g h
proof -
have FH: "F f *⇩u H h = H h *⇩u F f"
using assms compatible_def by metis
have GH: "G g *⇩u H h = H h *⇩u G g"
using assms compatible_def by metis
have ‹(F; G) (f ⊗⇩u g) *⇩u (H h) = F f *⇩u G g *⇩u H h›
using ‹compatible F G› by (subst register_pair_apply, auto)
also have ‹… = H h *⇩u F f *⇩u G g›
using FH GH by (metis comp_update_assoc)
also have ‹… = H h *⇩u (F; G) (f ⊗⇩u g)›
using ‹compatible F G› by (subst register_pair_apply, auto simp: comp_update_assoc)
finally show ?thesis
by -
qed
then show "(F; G) fg *⇩u (H h) = (H h) *⇩u (F; G) fg" for fg h
apply (rule_tac tensor_extensionality[THEN fun_cong])
by auto
show "register H" and "register (F; G)"
by simp_all
qed
lemma compatible3'[simp]:
assumes "compatible F G" and "compatible G H" and "compatible F H"
shows "compatible F (G; H)"
apply (rule compatible_sym)
apply (rule compatible3)
using assms by (auto simp: compatible_sym)
lemma pair_o_swap[simp]:
assumes [simp]: "compatible A B"
shows "(A; B) o swap = (B; A)"
proof (rule tensor_extensionality)
have [simp]: "preregister A" "preregister B"
apply (metis (no_types, opaque_lifting) assms compatible_register1 register_preregister)
by (metis (full_types) assms compatible_register2 register_preregister)
then show ‹preregister ((A; B) ∘ swap)›
by simp
show ‹preregister (B; A)›
by (metis (no_types, lifting) assms compatible_sym register_preregister pair_is_register)
show ‹((A; B) ∘ swap) (a ⊗⇩u b) = (B; A) (a ⊗⇩u b)› for a b
apply (simp only: o_def swap_apply)
apply (subst register_pair_apply, simp)
apply (subst register_pair_apply, simp add: compatible_sym)
by (metis (no_types, lifting) assms compatible_def)
qed
subsection ‹Compatibility of register tensor products›
lemma compatible_register_tensor:
fixes F :: ‹'a::type update ⇒ 'e::type update› and G :: ‹'b::type update ⇒ 'f::type update›
and F' :: ‹'c::type update ⇒ 'e update› and G' :: ‹'d::type update ⇒ 'f update›
assumes [simp]: ‹compatible F F'›
assumes [simp]: ‹compatible G G'›
shows ‹compatible (F ⊗⇩r G) (F' ⊗⇩r G')›
proof -
note [intro!] =
comp_preregister[OF _ preregister_mult_right, unfolded o_def]
comp_preregister[OF _ preregister_mult_left, unfolded o_def]
comp_preregister
register_tensor_is_register
have [simp]: ‹register F› ‹register G› ‹register F'› ‹register G'›
using assms compatible_def by blast+
have [simp]: ‹register (F ⊗⇩r G)› ‹register (F' ⊗⇩r G')›
by (auto simp add: register_tensor_def)
have [simp]: ‹register (F;F')› ‹register (G;G')›
by auto
define reorder :: ‹(('a×'b) × ('c×'d)) update ⇒ (('a×'c) × ('b×'d)) update›
where ‹reorder = ((Fst o Fst; Snd o Fst); (Fst o Snd; Snd o Snd))›
have [simp]: ‹preregister reorder›
by (auto simp: reorder_def)
have [simp]: ‹reorder ((a ⊗⇩u b) ⊗⇩u (c ⊗⇩u d)) = ((a ⊗⇩u c) ⊗⇩u (b ⊗⇩u d))› for a b c d
apply (simp add: reorder_def register_pair_apply)
by (simp add: Fst_def Snd_def tensor_update_mult)
define Φ where ‹Φ c d = ((F;F') ⊗⇩r (G;G')) o reorder o (λσ. σ ⊗⇩u (c ⊗⇩u d))› for c d
have [simp]: ‹preregister (Φ c d)› for c d
unfolding Φ_def
by (auto intro: register_preregister)
have ‹Φ c d (a ⊗⇩u b) = (F ⊗⇩r G) (a ⊗⇩u b) *⇩u (F' ⊗⇩r G') (c ⊗⇩u d)› for a b c d
unfolding Φ_def by (auto simp: register_pair_apply tensor_update_mult)
then have Φ1: ‹Φ c d σ = (F ⊗⇩r G) σ *⇩u (F' ⊗⇩r G') (c ⊗⇩u d)› for c d σ
apply (rule_tac fun_cong[of _ _ σ])
apply (rule tensor_extensionality)
by auto
have ‹Φ c d (a ⊗⇩u b) = (F' ⊗⇩r G') (c ⊗⇩u d) *⇩u (F ⊗⇩r G) (a ⊗⇩u b)› for a b c d
unfolding Φ_def apply (auto simp: register_pair_apply)
by (metis assms(1) assms(2) compatible_def tensor_update_mult)
then have Φ2: ‹Φ c d σ = (F' ⊗⇩r G') (c ⊗⇩u d) *⇩u (F ⊗⇩r G) σ› for c d σ
apply (rule_tac fun_cong[of _ _ σ])
apply (rule tensor_extensionality)
by auto
from Φ1 Φ2 have ‹(F ⊗⇩r G) σ *⇩u (F' ⊗⇩r G') τ = (F' ⊗⇩r G') τ *⇩u (F ⊗⇩r G) σ› for τ σ
apply (rule_tac fun_cong[of _ _ τ])
apply (rule tensor_extensionality)
by auto
then show ?thesis
apply (rule compatibleI[rotated -1])
by auto
qed
subsection ‹Associativity of the tensor product›
definition assoc :: ‹(('a::type×'b::type)×'c::type) update ⇒ ('a×('b×'c)) update› where
‹assoc = ((Fst; Snd o Fst); Snd o Snd)›
lemma assoc_is_hom[simp]: ‹preregister assoc›
by (auto simp: assoc_def)
lemma assoc_apply[simp]: ‹assoc ((a ⊗⇩u b) ⊗⇩u c) = (a ⊗⇩u (b ⊗⇩u c))›
by (auto simp: assoc_def register_pair_apply Fst_def Snd_def tensor_update_mult)
definition assoc' :: ‹('a×('b×'c)) update ⇒ (('a::type×'b::type)×'c::type) update› where
‹assoc' = (Fst o Fst; (Fst o Snd; Snd))›
lemma assoc'_is_hom[simp]: ‹preregister assoc'›
by (auto simp: assoc'_def)
lemma assoc'_apply[simp]: ‹assoc' (a ⊗⇩u (b ⊗⇩u c)) = ((a ⊗⇩u b) ⊗⇩u c)›
by (auto simp: assoc'_def register_pair_apply Fst_def Snd_def tensor_update_mult)
lemma register_assoc[simp]: ‹register assoc›
unfolding assoc_def
by force
lemma register_assoc'[simp]: ‹register assoc'›
unfolding assoc'_def
by force
lemma pair_o_assoc[simp]:
assumes [simp]: ‹compatible F G› ‹compatible G H› ‹compatible F H›
shows ‹(F; (G; H)) ∘ assoc = ((F; G); H)›
proof (rule tensor_extensionality3')
show ‹register ((F; (G; H)) ∘ assoc)›
by simp
show ‹register ((F; G); H)›
by simp
show ‹((F; (G; H)) ∘ assoc) ((f ⊗⇩u g) ⊗⇩u h) = ((F; G); H) ((f ⊗⇩u g) ⊗⇩u h)› for f g h
by (simp add: register_pair_apply assoc_apply comp_update_assoc)
qed
lemma pair_o_assoc'[simp]:
assumes [simp]: ‹compatible F G› ‹compatible G H› ‹compatible F H›
shows ‹((F; G); H) ∘ assoc' = (F; (G; H))›
proof (rule tensor_extensionality3)
show ‹register (((F; G); H) ∘ assoc')›
by simp
show ‹register (F; (G; H))›
by simp
show ‹(((F; G); H) ∘ assoc') (f ⊗⇩u g ⊗⇩u h) = (F; (G; H)) (f ⊗⇩u g ⊗⇩u h)› for f g h
by (simp add: register_pair_apply assoc'_apply comp_update_assoc)
qed
lemma assoc'_o_assoc[simp]: ‹assoc' o assoc = id›
apply (rule tensor_extensionality3')
by auto
lemma assoc'_assoc[simp]: ‹assoc' (assoc x) = x›
by (simp add: pointfree_idE)
lemma assoc_o_assoc'[simp]: ‹assoc o assoc' = id›
apply (rule tensor_extensionality3)
by auto
lemma assoc_assoc'[simp]: ‹assoc (assoc' x) = x›
by (simp add: pointfree_idE)
lemma inv_assoc[simp]: ‹inv assoc = assoc'›
using assoc'_o_assoc assoc_o_assoc' inv_unique_comp by blast
lemma inv_assoc'[simp]: ‹inv assoc' = assoc›
by (simp add: inv_equality)
lemma [simp]: ‹bij assoc›
using assoc'_o_assoc assoc_o_assoc' o_bij by blast
lemma [simp]: ‹bij assoc'›
using assoc'_o_assoc assoc_o_assoc' o_bij by blast
subsection ‹Iso-registers›
definition ‹iso_register F ⟷ register F ∧ (∃G. register G ∧ F o G = id ∧ G o F = id)›
for F :: ‹_::type update ⇒ _::type update›
lemma iso_registerI:
assumes ‹register F› ‹register G› ‹F o G = id› ‹G o F = id›
shows ‹iso_register F›
using assms(1) assms(2) assms(3) assms(4) iso_register_def by blast
lemma iso_register_inv: ‹iso_register F ⟹ iso_register (inv F)›
by (metis inv_unique_comp iso_register_def)
lemma iso_register_inv_comp1: ‹iso_register F ⟹ inv F o F = id›
using inv_unique_comp iso_register_def by blast
lemma iso_register_inv_comp2: ‹iso_register F ⟹ F o inv F = id›
using inv_unique_comp iso_register_def by blast
lemma iso_register_id[simp]: ‹iso_register id›
by (simp add: iso_register_def)
lemma iso_register_is_register: ‹iso_register F ⟹ register F›
using iso_register_def by blast
lemma iso_register_comp[simp]:
assumes [simp]: ‹iso_register F› ‹iso_register G›
shows ‹iso_register (F o G)›
proof -
from assms obtain F' G' where [simp]: ‹register F'› ‹register G'› ‹F o F' = id› ‹F' o F = id›
‹G o G' = id› ‹G' o G = id›
by (meson iso_register_def)
show ?thesis
apply (rule iso_registerI[where G=‹G' o F'›])
apply (auto simp: register_tensor_is_register iso_register_is_register register_tensor_distrib)
apply (metis ‹F ∘ F' = id› ‹G ∘ G' = id› fcomp_assoc fcomp_comp id_fcomp)
by (metis (no_types, lifting) ‹F ∘ F' = id› ‹F' ∘ F = id› ‹G' ∘ G = id› fun.map_comp inj_iff inv_unique_comp o_inv_o_cancel)
qed
lemma iso_register_tensor_is_iso_register[simp]:
assumes [simp]: ‹iso_register F› ‹iso_register G›
shows ‹iso_register (F ⊗⇩r G)›
proof -
from assms obtain F' G' where [simp]: ‹register F'› ‹register G'› ‹F o F' = id› ‹F' o F = id›
‹G o G' = id› ‹G' o G = id›
by (meson iso_register_def)
show ?thesis
apply (rule iso_registerI[where G=‹F' ⊗⇩r G'›])
by (auto simp: register_tensor_is_register iso_register_is_register register_tensor_distrib)
qed
lemma iso_register_bij: ‹iso_register F ⟹ bij F›
using iso_register_def o_bij by auto
lemma inv_register_tensor[simp]:
assumes [simp]: ‹iso_register F› ‹iso_register G›
shows ‹inv (F ⊗⇩r G) = inv F ⊗⇩r inv G›
apply (auto intro!: inj_imp_inv_eq bij_is_inj iso_register_bij
simp: register_tensor_distrib[unfolded o_def, THEN fun_cong] iso_register_is_register
iso_register_inv bij_is_surj iso_register_bij surj_f_inv_f)
by (metis eq_id_iff register_tensor_id)
lemma iso_register_swap[simp]: ‹iso_register swap›
apply (rule iso_registerI[of _ swap])
by auto
lemma iso_register_assoc[simp]: ‹iso_register assoc›
apply (rule iso_registerI[of _ assoc'])
by auto
lemma iso_register_assoc'[simp]: ‹iso_register assoc'›
apply (rule iso_registerI[of _ assoc])
by auto
definition ‹equivalent_registers F G ⟷ (register F ∧ (∃I. iso_register I ∧ F o I = G))›
for F G :: ‹_::type update ⇒ _::type update›
lemma iso_register_equivalent_id[simp]: ‹equivalent_registers id F ⟷ iso_register F›
by (simp add: equivalent_registers_def)
lemma equivalent_registersI:
assumes ‹register F›
assumes ‹iso_register I›
assumes ‹F o I = G›
shows ‹equivalent_registers F G›
using assms unfolding equivalent_registers_def by blast
lemma equivalent_registers_register_left: ‹equivalent_registers F G ⟹ register F›
using equivalent_registers_def by auto
lemma equivalent_registers_register_right: ‹register G› if ‹equivalent_registers F G›
by (metis equivalent_registers_def iso_register_def register_comp that)
lemma equivalent_registers_sym:
assumes ‹equivalent_registers F G›
shows ‹equivalent_registers G F›
by (smt (verit) assms comp_id equivalent_registers_def equivalent_registers_register_right fun.map_comp iso_register_def)
lemma equivalent_registers_trans[trans]:
assumes ‹equivalent_registers F G› and ‹equivalent_registers G H›
shows ‹equivalent_registers F H›
proof -
from assms have [simp]: ‹register F› ‹register G›
by (auto simp: equivalent_registers_def)
from assms(1) obtain I where [simp]: ‹iso_register I› and ‹F o I = G›
using equivalent_registers_def by blast
from assms(2) obtain J where [simp]: ‹iso_register J› and ‹G o J = H›
using equivalent_registers_def by blast
have ‹register F›
by (auto simp: equivalent_registers_def)
moreover have ‹iso_register (I o J)›
using ‹iso_register I› ‹iso_register J› iso_register_comp by blast
moreover have ‹F o (I o J) = H›
by (simp add: ‹F ∘ I = G› ‹G ∘ J = H› o_assoc)
ultimately show ?thesis
by (rule equivalent_registersI)
qed
lemma equivalent_registers_assoc[simp]:
assumes [simp]: ‹compatible F G› ‹compatible F H› ‹compatible G H›
shows ‹equivalent_registers (F;(G;H)) ((F;G);H)›
apply (rule equivalent_registersI[where I=assoc])
by auto
lemma equivalent_registers_pair_right:
assumes [simp]: ‹compatible F G›
assumes eq: ‹equivalent_registers G H›
shows ‹equivalent_registers (F;G) (F;H)›
proof -
from eq obtain I where [simp]: ‹iso_register I› and ‹G o I = H›
by (metis equivalent_registers_def)
then have *: ‹(F;G) ∘ (id ⊗⇩r I) = (F;H)›
by (auto intro!: tensor_extensionality register_comp register_preregister register_tensor_is_register
simp: register_pair_apply iso_register_is_register)
show ?thesis
apply (rule equivalent_registersI[where I=‹id ⊗⇩r I›])
using * by (auto intro!: iso_register_tensor_is_iso_register)
qed
lemma equivalent_registers_pair_left:
assumes [simp]: ‹compatible F G›
assumes eq: ‹equivalent_registers F H›
shows ‹equivalent_registers (F;G) (H;G)›
proof -
from eq obtain I where [simp]: ‹iso_register I› and ‹F o I = H›
by (metis equivalent_registers_def)
then have *: ‹(F;G) ∘ (I ⊗⇩r id) = (H;G)›
by (auto intro!: tensor_extensionality register_comp register_preregister register_tensor_is_register
simp: register_pair_apply iso_register_is_register)
show ?thesis
apply (rule equivalent_registersI[where I=‹I ⊗⇩r id›])
using * by (auto intro!: iso_register_tensor_is_iso_register)
qed
lemma equivalent_registers_comp:
assumes ‹register H›
assumes ‹equivalent_registers F G›
shows ‹equivalent_registers (H o F) (H o G)›
by (metis (no_types, lifting) assms(1) assms(2) comp_assoc equivalent_registers_def register_comp)
subsection ‹Compatibility simplification›
text ‹The simproc ‹compatibility_warn› produces helpful warnings for subgoals of the form
\<^term>‹compatible x y› that are probably unsolvable due to missing declarations of
variable compatibility facts. Same for subgoals of the form \<^term>‹register x›.›
simproc_setup "compatibility_warn" ("compatible x y" | "register x") = ‹
let val thy_string = Markup.markup (Theory.get_markup \<^theory>) (Context.theory_name \<^theory>)
in
fn m => fn ctxt => fn ct => let
val (x,y) = case Thm.term_of ct of
Const(\<^const_name>‹compatible›,_ ) $ x $ y => (x, SOME y)
| Const(\<^const_name>‹register›,_ ) $ x => (x, NONE)
val str : string lazy = Lazy.lazy (fn () => Syntax.string_of_term ctxt (Thm.term_of ct))
fun w msg = warning (msg ^ "\n(Disable these warnings with: using [[simproc del: "^thy_string^".compatibility_warn]])")
val _ = case (x,y) of
(Free(n,T), SOME (Free(n',T'))) =>
if String.isPrefix ":" n orelse String.isPrefix ":" n' then
w ("Simplification subgoal " ^ Lazy.force str ^ " contains a bound variable.\n" ^
"Try to add some assumptions that makes this goal solvable by the simplifier")
else if n=n' then (if T=T' then ()
else w ("In simplification subgoal " ^ Lazy.force str ^
", variables have same name and different types.\n" ^
"Probably something is wrong."))
else w ("Simplification subgoal " ^ Lazy.force str ^
" occurred but cannot be solved.\n" ^
"Please add assumption/fact [simp]: ‹" ^ Lazy.force str ^
"› somewhere.")
| (Free(n,T), NONE) =>
if String.isPrefix ":" n then
w ("Simplification subgoal '" ^ Lazy.force str ^ "' contains a bound variable.\n" ^
"Try to add some assumptions that makes this goal solvable by the simplifier")
else w ("Simplification subgoal " ^ Lazy.force str ^ " occurred but cannot be solved.\n" ^
"Please add assumption/fact [simp]: ‹" ^ Lazy.force str ^ "› somewhere.")
| _ => ()
in NONE end
end›
named_theorems register_attribute_rule_immediate
named_theorems register_attribute_rule
lemmas [register_attribute_rule] = conjunct1 conjunct2 iso_register_is_register iso_register_is_register[OF iso_register_inv]
lemmas [register_attribute_rule_immediate] = compatible_sym compatible_register1 compatible_register2
asm_rl[of ‹compatible _ _›] asm_rl[of ‹iso_register _›] asm_rl[of ‹register _›] iso_register_inv
text ‹The following declares an attribute ‹[register]›. When the attribute is applied to a fact
of the form \<^term>‹register F›, \<^term>‹iso_register F›, \<^term>‹compatible F G› or a conjunction of these,
then those facts are added to the simplifier together with some derived theorems
(e.g., \<^term>‹compatible F G› also adds \<^term>‹register F›).
In theory ‹Laws_Complement›, support for \<^term>‹is_unit_register F› and \<^term>‹complements F G› is
added to this attribute.›
setup ‹
let
fun add thm results =
Net.insert_term (K true) (Thm.concl_of thm, thm) results
handle Net.INSERT => results
fun try_rule f thm rule state = case SOME (rule OF [thm]) handle THM _ => NONE of
NONE => state | SOME th => f th state
fun collect (rules,rules_immediate) thm results =
results |> fold (try_rule add thm) rules_immediate |> fold (try_rule (collect (rules,rules_immediate)) thm) rules
fun declare thm context = let
val ctxt = Context.proof_of context
val rules = Named_Theorems.get ctxt @{named_theorems register_attribute_rule}
val rules_immediate = Named_Theorems.get ctxt @{named_theorems register_attribute_rule_immediate}
val thms = collect (rules,rules_immediate) thm Net.empty |> Net.entries
in Simplifier.map_ss (fn ctxt => ctxt addsimps thms) context end
in
Attrib.setup \<^binding>‹register›
(Scan.succeed (Thm.declaration_attribute declare))
"Add register-related rules to the simplifier"
end
›
subsection ‹Notation›
no_notation map_comp (infixl "*⇩u" 55)
no_notation tensor_update (infixr "⊗⇩u" 70)
bundle register_notation begin
notation register_tensor (infixr "⊗⇩r" 70)
notation register_pair ("'(_;_')")
end
bundle no_register_notation begin
no_notation register_tensor (infixr "⊗⇩r" 70)
no_notation register_pair ("'(_;_')")
end
end
Theory Misc
section ‹Miscellaneous facts›
text ‹This theory proves various facts that are not directly related to this developments
but do not occur in the imported theories.›
theory Misc
imports
Complex_Bounded_Operators.Cblinfun_Code
"HOL-Library.Z2"
Jordan_Normal_Form.Matrix
begin
no_notation Order.top ("⊤ı")
no_notation m_inv ("invı _" [81] 80)
unbundle no_vec_syntax
unbundle no_inner_syntax
unbundle cblinfun_notation
unbundle jnf_notation
abbreviation "butterket i j ≡ butterfly (ket i) (ket j)"
abbreviation "selfbutterket i ≡ butterfly (ket i) (ket i)"
text ‹The following declares the ML antiquotation ▩‹fact›. In ML code,
▩‹@{fact f}› for a theorem/fact name f is replaced by an ML string
containing a printable(!) representation of fact. (I.e.,
if you print that string using writeln, the user can ctrl-click on it.)
This is useful when constructing diagnostic messages in ML code, e.g.,
▩‹"Use the theorem " ^ @{fact thmname} ^ "here."››
setup ‹ML_Antiquotation.inline_embedded \<^binding>‹fact›
((Args.context -- Scan.lift Args.name_position) >> (fn (ctxt,namepos) => let
val facts = Proof_Context.facts_of ctxt
val fullname = Facts.check (Context.Proof ctxt) facts namepos
val (markup, shortname) = Proof_Context.markup_extern_fact ctxt fullname
val string = Markup.markups markup shortname
in ML_Syntax.print_string string end
))
›
instantiation bit :: enum begin
definition "enum_bit = [0::bit,1]"
definition "enum_all_bit P ⟷ P (0::bit) ∧ P 1"
definition "enum_ex_bit P ⟷ P (0::bit) ∨ P 1"
instance
apply intro_classes
apply (auto simp: enum_bit_def enum_all_bit_def enum_ex_bit_def)
apply (metis bit_not_one_iff)
by (metis bit_not_zero_iff)
end
lemma card_bit[simp]: "CARD(bit) = 2"
using card_2_iff' by force
instantiation bit :: card_UNIV begin
definition "finite_UNIV = Phantom(bit) True"
definition "card_UNIV = Phantom(bit) 2"
instance
apply intro_classes
by (simp_all add: finite_UNIV_bit_def card_UNIV_bit_def)
end
lemma mat_of_rows_list_carrier[simp]:
"mat_of_rows_list n vs ∈ carrier_mat (length vs) n"
"dim_row (mat_of_rows_list n vs) = length vs"
"dim_col (mat_of_rows_list n vs) = n"
unfolding mat_of_rows_list_def by auto
lemma apply_id_cblinfun[simp]: ‹(*⇩V) id_cblinfun = id›
by auto
text ‹Overriding \\<^theory>‹Complex_Bounded_Operators.Complex_Bounded_Linear_Function›.\<^term>‹sandwich›.
The latter is the same function but defined as a \<^typ>‹(_,_) cblinfun› which is less convenient for us.›
definition sandwich where ‹sandwich a b = a o⇩C⇩L b o⇩C⇩L a*›
lemma clinear_sandwich[simp]: ‹clinear (sandwich a)›
apply (rule clinearI)
apply (simp add: bounded_cbilinear.add_left bounded_cbilinear_cblinfun_compose bounded_cbilinear.add_right sandwich_def)
by (simp add: sandwich_def)
lemma sandwich_id[simp]: ‹sandwich id_cblinfun = id›
by (auto simp: sandwich_def)
lemma mat_of_cblinfun_sandwich:
fixes a :: "(_::onb_enum, _::onb_enum) cblinfun"
shows ‹mat_of_cblinfun (sandwich a b) = (let a' = mat_of_cblinfun a in a' * mat_of_cblinfun b * mat_adjoint a')›
by (simp add: mat_of_cblinfun_compose sandwich_def Let_def mat_of_cblinfun_adj)
lemma prod_cases3' [cases type]:
obtains (fields) a b c where "y = ((a, b), c)"
by (cases y, case_tac a) blast
lemma lift_cblinfun_comp:
assumes ‹a o⇩C⇩L b = c›
shows ‹a o⇩C⇩L b = c›
and ‹a o⇩C⇩L (b o⇩C⇩L d) = c o⇩C⇩L d›
and ‹a *⇩S (b *⇩S S) = c *⇩S S›
and ‹a *⇩V (b *⇩V x) = c *⇩V x›
apply (fact assms)
apply (simp add: assms cblinfun_assoc_left(1))
using assms cblinfun_assoc_left(2) apply force
using assms by force
text ‹We define the following abbreviations:
▪ ‹mutually f (x⇩1,x⇩2,…,x⇩n)› expands to the conjuction of all \<^term>‹f x⇩i x⇩j› with \<^term>‹i≠j›.
▪ ‹each f (x⇩1,x⇩2,…,x⇩n)› expands to the conjuction of all \<^term>‹f x⇩i›.›
syntax "_mutually" :: "'a ⇒ args ⇒ 'b" ("mutually _ '(_')")
syntax "_mutually2" :: "'a ⇒ 'b ⇒ args ⇒ args ⇒ 'c"
translations "mutually f (x)" => "CONST True"
translations "mutually f (_args x y)" => "f x y ∧ f y x"
translations "mutually f (_args x (_args x' xs))" => "_mutually2 f x (_args x' xs) (_args x' xs)"
translations "_mutually2 f x y zs" => "f x y ∧ f y x ∧ _mutually f zs"
translations "_mutually2 f x (_args y ys) zs" => "f x y ∧ f y x ∧ _mutually2 f x ys zs"
syntax "_each" :: "'a ⇒ args ⇒ 'b" ("each _ '(_')")
translations "each f (x)" => "f x"
translations "_each f (_args x xs)" => "f x ∧ _each f xs"
lemma enum_inj:
assumes "i < CARD('a)" and "j < CARD('a)"
shows "(Enum.enum ! i :: 'a::enum) = Enum.enum ! j ⟷ i = j"
using inj_on_nth[OF enum_distinct, where I=‹{..<CARD('a)}›]
using assms by (auto dest: inj_onD simp flip: card_UNIV_length_enum)
lemma [simp]: "dim_col (mat_adjoint m) = dim_row m"
unfolding mat_adjoint_def by simp
lemma [simp]: "dim_row (mat_adjoint m) = dim_col m"
unfolding mat_adjoint_def by simp
lemma invI:
assumes ‹inj f›
assumes ‹x = f y›
shows ‹inv f x = y›
by (simp add: assms(1) assms(2))
instantiation prod :: (default,default) default begin
definition ‹default_prod = (default, default)›
instance..
end
instance bit :: default..
lemma surj_from_comp:
assumes ‹surj (g o f)›
assumes ‹inj g›
shows ‹surj f›
by (metis assms(1) assms(2) f_inv_into_f fun.set_map inj_image_mem_iff iso_tuple_UNIV_I surj_iff_all)
lemma double_exists: ‹(∃x y. Q x y) ⟷ (∃z. Q (fst z) (snd z))›
by simp
end
Theory Finite_Tensor_Product
section ‹Tensor products (finite dimensional)›
theory Finite_Tensor_Product
imports Complex_Bounded_Operators.Complex_L2 Misc
begin
declare cblinfun.scaleC_right[simp]
unbundle cblinfun_notation
no_notation m_inv ("invı _" [81] 80)
lift_definition tensor_ell2 :: ‹'a::finite ell2 ⇒ 'b::finite ell2 ⇒ ('a×'b) ell2› (infixr "⊗⇩s" 70) is
‹λψ φ (i,j). ψ i * φ j›
by simp
lemma tensor_ell2_add2: ‹tensor_ell2 a (b + c) = tensor_ell2 a b + tensor_ell2 a c›
apply transfer apply (rule ext) apply (auto simp: case_prod_beta)
by (meson algebra_simps)
lemma tensor_ell2_add1: ‹tensor_ell2 (a + b) c = tensor_ell2 a c + tensor_ell2 b c›
apply transfer apply (rule ext) apply (auto simp: case_prod_beta)
by (simp add: vector_space_over_itself.scale_left_distrib)
lemma tensor_ell2_scaleC2: ‹tensor_ell2 a (c *⇩C b) = c *⇩C tensor_ell2 a b›
apply transfer apply (rule ext) by (auto simp: case_prod_beta)
lemma tensor_ell2_scaleC1: ‹tensor_ell2 (c *⇩C a) b = c *⇩C tensor_ell2 a b›
apply transfer apply (rule ext) by (auto simp: case_prod_beta)
lemma tensor_ell2_inner_prod[simp]: ‹⟨tensor_ell2 a b, tensor_ell2 c d⟩ = ⟨a,c⟩ * ⟨b,d⟩›
apply transfer
by (auto simp: case_prod_beta sum_product sum.cartesian_product mult.assoc mult.left_commute)
lemma clinear_tensor_ell21: "clinear (λb. tensor_ell2 a b)"
apply (rule clinearI; transfer)
apply (auto simp: case_prod_beta)
by (simp add: cond_case_prod_eta algebra_simps)
lemma clinear_tensor_ell22: "clinear (λa. tensor_ell2 a b)"
apply (rule clinearI; transfer)
apply (auto simp: case_prod_beta)
by (simp add: case_prod_beta' algebra_simps)
lemma tensor_ell2_ket[simp]: "tensor_ell2 (ket i) (ket j) = ket (i,j)"
apply transfer by auto
definition tensor_op :: ‹('a ell2, 'b::finite ell2) cblinfun ⇒ ('c ell2, 'd::finite ell2) cblinfun
⇒ (('a×'c) ell2, ('b×'d) ell2) cblinfun› (infixr "⊗⇩o" 70) where
‹tensor_op M N = (SOME P. ∀a c. P *⇩V (ket (a,c))
= tensor_ell2 (M *⇩V ket a) (N *⇩V ket c))›
lemma tensor_op_ket:
fixes a :: ‹'a::finite› and b :: ‹'b› and c :: ‹'c::finite› and d :: ‹'d›
shows ‹tensor_op M N *⇩V (ket (a,c)) = tensor_ell2 (M *⇩V ket a) (N *⇩V ket c)›
proof -
define S :: ‹('a×'c) ell2 set› where "S = ket ` UNIV"
define φ where ‹φ = (λ(a,c). tensor_ell2 (M *⇩V ket a) (N *⇩V ket c))›
define φ' where ‹φ' = φ ∘ inv ket›
have def: ‹tensor_op M N = (SOME P. ∀a c. P *⇩V (ket (a,c)) = φ (a,c))›
unfolding tensor_op_def φ_def by auto
have ‹cindependent S›
using S_def cindependent_ket by blast
moreover have ‹cspan S = UNIV›
using S_def cspan_range_ket_finite by blast
ultimately have "cblinfun_extension_exists S φ'"
by (rule cblinfun_extension_exists_finite_dim)
then have "∃P. ∀x∈S. P *⇩V x = φ' x"
unfolding cblinfun_extension_exists_def by auto
then have ex: ‹∃P. ∀a c. P *⇩V ket (a,c) = φ (a,c)›
by (metis S_def φ'_def comp_eq_dest_lhs inj_ket inv_f_f rangeI)
then have ‹tensor_op M N *⇩V (ket (a,c)) = φ (a,c)›
unfolding def apply (rule someI2_ex[where P=‹λP. ∀a c. P *⇩V (ket (a,c)) = φ (a,c)›])
by auto
then show ?thesis
unfolding φ_def by auto
qed
lemma tensor_op_ell2: "tensor_op A B *⇩V tensor_ell2 ψ φ = tensor_ell2 (A *⇩V ψ) (B *⇩V φ)"
proof -
have 1: ‹clinear (λa. tensor_op A B *⇩V tensor_ell2 a (ket b))› for b
by (auto intro!: clinearI simp: tensor_ell2_add1 tensor_ell2_scaleC1 cblinfun.add_right)
have 2: ‹clinear (λa. tensor_ell2 (A *⇩V a) (B *⇩V ket b))› for b
by (auto intro!: clinearI simp: tensor_ell2_add1 tensor_ell2_scaleC1 cblinfun.add_right)
have 3: ‹clinear (λa. tensor_op A B *⇩V tensor_ell2 ψ a)›
by (auto intro!: clinearI simp: tensor_ell2_add2 tensor_ell2_scaleC2 cblinfun.add_right)
have 4: ‹clinear (λa. tensor_ell2 (A *⇩V ψ) (B *⇩V a))›
by (auto intro!: clinearI simp: tensor_ell2_add2 tensor_ell2_scaleC2 cblinfun.add_right)
have eq_ket_ket: ‹tensor_op A B *⇩V tensor_ell2 (ket a) (ket b) = tensor_ell2 (A *⇩V ket a) (B *⇩V ket b)› for a b
by (simp add: tensor_op_ket)
have eq_ket: ‹tensor_op A B *⇩V tensor_ell2 ψ (ket b) = tensor_ell2 (A *⇩V ψ) (B *⇩V ket b)› for b
apply (rule fun_cong[where x=ψ])
using 1 2 eq_ket_ket by (rule clinear_equal_ket)
show ?thesis
apply (rule fun_cong[where x=φ])
using 3 4 eq_ket by (rule clinear_equal_ket)
qed
lemma comp_tensor_op: "(tensor_op a b) o⇩C⇩L (tensor_op c d) = tensor_op (a o⇩C⇩L c) (b o⇩C⇩L d)"
for a :: "'e::finite ell2 ⇒⇩C⇩L 'c::finite ell2" and b :: "'f::finite ell2 ⇒⇩C⇩L 'd::finite ell2" and
c :: "'a::finite ell2 ⇒⇩C⇩L 'e ell2" and d :: "'b::finite ell2 ⇒⇩C⇩L 'f ell2"
apply (rule equal_ket)
apply (rename_tac ij, case_tac ij, rename_tac i j, hypsubst_thin)
by (simp flip: tensor_ell2_ket add: tensor_op_ell2 cblinfun_apply_cblinfun_compose)
lemma tensor_op_cbilinear: ‹cbilinear (tensor_op :: 'a::finite ell2 ⇒⇩C⇩L 'b::finite ell2
⇒ 'c::finite ell2 ⇒⇩C⇩L 'd::finite ell2 ⇒ _)›
proof -
have ‹clinear (λb::'c ell2 ⇒⇩C⇩L 'd ell2. tensor_op a b)› for a :: ‹'a ell2 ⇒⇩C⇩L 'b ell2›
apply (rule clinearI)
apply (rule equal_ket, rename_tac ij, case_tac ij, rename_tac i j, hypsubst_thin)
apply (simp flip: tensor_ell2_ket add: tensor_op_ell2 cblinfun.add_left tensor_ell2_add2)
apply (rule equal_ket, rename_tac ij, case_tac ij, rename_tac i j, hypsubst_thin)
by (simp add: scaleC_cblinfun.rep_eq tensor_ell2_scaleC2 tensor_op_ket)
moreover have ‹clinear (λa::'a::finite ell2 ⇒⇩C⇩L 'b::finite ell2. tensor_op a b)› for b :: ‹'c ell2 ⇒⇩C⇩L 'd ell2›
apply (rule clinearI)
apply (rule equal_ket, rename_tac ij, case_tac ij, rename_tac i j, hypsubst_thin)
apply (simp flip: tensor_ell2_ket add: tensor_op_ell2 cblinfun.add_left tensor_ell2_add1)
apply (rule equal_ket, rename_tac ij, case_tac ij, rename_tac i j, hypsubst_thin)
by (simp add: scaleC_cblinfun.rep_eq tensor_ell2_scaleC1 tensor_op_ket)
ultimately show ?thesis
unfolding cbilinear_def by auto
qed
lemma tensor_butter: ‹tensor_op (butterket i j) (butterket k l) = butterket (i,k) (j,l)›
for i :: "_" and j :: "_::finite" and k :: "_" and l :: "_::finite"
apply (rule equal_ket, rename_tac x, case_tac x)
apply (auto simp flip: tensor_ell2_ket simp: cblinfun_apply_cblinfun_compose tensor_op_ell2 butterfly_def)
by (auto simp: tensor_ell2_scaleC1 tensor_ell2_scaleC2)
lemma cspan_tensor_op: ‹cspan {tensor_op (butterket i j) (butterket k l)| i (j::_::finite) k (l::_::finite). True} = UNIV›
unfolding tensor_butter
apply (subst cspan_butterfly_ket[symmetric])
by (metis surj_pair)
lemma cindependent_tensor_op: ‹cindependent {tensor_op (butterket i j) (butterket k l)| i (j::_::finite) k (l::_::finite). True}›
unfolding tensor_butter
using cindependent_butterfly_ket
by (smt (z3) Collect_mono_iff complex_vector.independent_mono)
lemma tensor_extensionality:
fixes F G :: ‹((('a::finite × 'b::finite) ell2) ⇒⇩C⇩L (('c::finite × 'd::finite) ell2)) ⇒ 'e::complex_vector›
assumes [simp]: "clinear F" "clinear G"
assumes tensor_eq: "(⋀a b. F (tensor_op a b) = G (tensor_op a b))"
shows "F = G"
proof (rule ext, rule complex_vector.linear_eq_on_span[where f=F and g=G])
show ‹clinear F› and ‹clinear G›
using assms by (simp_all add: cbilinear_def)
show ‹x ∈ cspan {tensor_op (butterket i j) (butterket k l)| i j k l. True}›
for x :: ‹('a × 'b) ell2 ⇒⇩C⇩L ('c × 'd) ell2›
using cspan_tensor_op by auto
show ‹F x = G x› if ‹x ∈ {tensor_op (butterket i j) (butterket k l) |i j k l. True}› for x
using that by (auto simp: tensor_eq)
qed
lemma tensor_id[simp]: ‹tensor_op id_cblinfun id_cblinfun = id_cblinfun›
apply (rule equal_ket, rename_tac x, case_tac x)
by (simp flip: tensor_ell2_ket add: tensor_op_ell2)
lemma tensor_op_adjoint: ‹(tensor_op a b)* = tensor_op (a*) (b*)›
apply (rule cinner_ket_adjointI[symmetric])
apply (auto simp flip: tensor_ell2_ket simp: tensor_op_ell2)
by (simp add: cinner_adj_left)
lemma tensor_butterfly[simp]: "tensor_op (butterfly ψ ψ') (butterfly φ φ') = butterfly (tensor_ell2 ψ φ) (tensor_ell2 ψ' φ')"
apply (rule equal_ket, rename_tac x, case_tac x)
by (simp flip: tensor_ell2_ket add: tensor_op_ell2 butterfly_def
cblinfun_apply_cblinfun_compose tensor_ell2_scaleC1 tensor_ell2_scaleC2)
definition tensor_lift :: ‹(('a1::finite ell2 ⇒⇩C⇩L 'a2::finite ell2) ⇒ ('b1::finite ell2 ⇒⇩C⇩L 'b2::finite ell2) ⇒ 'c)
⇒ ((('a1×'b1) ell2 ⇒⇩C⇩L ('a2×'b2) ell2) ⇒ 'c::complex_vector)› where
"tensor_lift F2 = (SOME G. clinear G ∧ (∀a b. G (tensor_op a b) = F2 a b))"
lemma
fixes F2 :: "'a::finite ell2 ⇒⇩C⇩L 'b::finite ell2
⇒ 'c::finite ell2 ⇒⇩C⇩L 'd::finite ell2
⇒ 'e::complex_normed_vector"
assumes "cbilinear F2"
shows tensor_lift_clinear: "clinear (tensor_lift F2)"
and tensor_lift_correct: ‹(λa b. tensor_lift F2 (tensor_op a b)) = F2›
proof -
define F2' t4 φ where
‹F2' = tensor_lift F2› and
‹t4 = (λ(i,j,k,l). tensor_op (butterket i j) (butterket k l))› and
‹φ m = (let (i,j,k,l) = inv t4 m in F2 (butterket i j) (butterket k l))› for m
have t4inj: "x = y" if "t4 x = t4 y" for x y
proof (rule ccontr)
obtain i j k l where x: "x = (i,j,k,l)" by (meson prod_cases4)
obtain i' j' k' l' where y: "y = (i',j',k',l')" by (meson prod_cases4)
have 1: "bra (i,k) *⇩V t4 x *⇩V ket (j,l) = 1"
by (auto simp: t4_def x tensor_op_ell2 butterfly_def cinner_ket simp flip: tensor_ell2_ket)
assume ‹x ≠ y›
then have 2: "bra (i,k) *⇩V t4 y *⇩V ket (j,l) = 0"
by (auto simp: t4_def x y tensor_op_ell2 butterfly_def cblinfun_apply_cblinfun_compose cinner_ket
simp flip: tensor_ell2_ket)
from 1 2 that
show False
by auto
qed
have ‹φ (tensor_op (butterket i j) (butterket k l)) = F2 (butterket i j) (butterket k l)› for i j k l
apply (subst asm_rl[of ‹tensor_op (butterket i j) (butterket k l) = t4 (i,j,k,l)›])
apply (simp add: t4_def)
by (auto simp add: injI t4inj inv_f_f φ_def)
have *: ‹range t4 = {tensor_op (butterket i j) (butterket k l) |i j k l. True}›
apply (auto simp: case_prod_beta t4_def)
using image_iff by fastforce
have "cblinfun_extension_exists (range t4) φ"
thm cblinfun_extension_exists_finite_dim[where φ=φ]
apply (rule cblinfun_extension_exists_finite_dim)
apply auto unfolding *
using cindependent_tensor_op
using cspan_tensor_op
by auto
then obtain G where G: ‹G *⇩V (t4 (i,j,k,l)) = F2 (butterket i j) (butterket k l)› for i j k l
apply atomize_elim
unfolding cblinfun_extension_exists_def
apply auto
by (metis (no_types, lifting) t4inj φ_def f_inv_into_f rangeI split_conv)
have *: ‹G *⇩V tensor_op (butterket i j) (butterket k l) = F2 (butterket i j) (butterket k l)› for i j k l
using G by (auto simp: t4_def)
have *: ‹G *⇩V tensor_op a (butterket k l) = F2 a (butterket k l)› for a k l
apply (rule complex_vector.linear_eq_on_span[where g=‹λa. F2 a _› and B=‹{butterket k l|k l. True}›])
unfolding cspan_butterfly_ket
using * apply (auto intro!: clinear_compose[unfolded o_def, where f=‹λa. tensor_op a _› and g=‹(*⇩V) G›])
apply (metis cbilinear_def tensor_op_cbilinear)
using assms unfolding cbilinear_def by blast
have G_F2: ‹G *⇩V tensor_op a b = F2 a b› for a b
apply (rule complex_vector.linear_eq_on_span[where g=‹F2 a› and B=‹{butterket k l|k l. True}›])
unfolding cspan_butterfly_ket
using * apply (auto simp: cblinfun.add_right clinearI
intro!: clinear_compose[unfolded o_def, where f=‹tensor_op a› and g=‹(*⇩V) G›])
apply (meson cbilinear_def tensor_op_cbilinear)
using assms unfolding cbilinear_def by blast
have ‹clinear F2' ∧ (∀a b. F2' (tensor_op a b) = F2 a b)›
unfolding F2'_def tensor_lift_def
apply (rule someI[where x=‹(*⇩V) G› and P=‹λG. clinear G ∧ (∀a b. G (tensor_op a b) = F2 a b)›])
using G_F2 by (simp add: cblinfun.add_right clinearI)
then show ‹clinear F2'› and ‹(λa b. tensor_lift F2 (tensor_op a b)) = F2›
unfolding F2'_def by auto
qed
lift_definition assoc_ell20 :: ‹(('a::finite×'b::finite)×'c::finite) ell2 ⇒ ('a×('b×'c)) ell2› is
‹λf (a,(b,c)). f ((a,b),c)›
by auto
lift_definition assoc_ell20' :: ‹('a::finite×('b::finite×'c::finite)) ell2 ⇒ (('a×'b)×'c) ell2› is
‹λf ((a,b),c). f (a,(b,c))›
by auto
lift_definition assoc_ell2 :: ‹(('a::finite×'b::finite)×'c::finite) ell2 ⇒⇩C⇩L ('a×('b×'c)) ell2›
is assoc_ell20
apply (subst bounded_clinear_finite_dim)
apply (rule clinearI; transfer)
by auto
lift_definition assoc_ell2' :: ‹('a::finite×('b::finite×'c::finite)) ell2 ⇒⇩C⇩L (('a×'b)×'c) ell2› is
assoc_ell20'
apply (subst bounded_clinear_finite_dim)
apply (rule clinearI; transfer)
by auto
lemma assoc_ell2_tensor: ‹assoc_ell2 *⇩V tensor_ell2 (tensor_ell2 a b) c = tensor_ell2 a (tensor_ell2 b c)›
apply (rule clinear_equal_ket[THEN fun_cong, where x=a])
apply (simp add: cblinfun.add_right clinearI tensor_ell2_add1 tensor_ell2_scaleC1)
apply (simp add: clinear_tensor_ell22)
apply (rule clinear_equal_ket[THEN fun_cong, where x=b])
apply (simp add: cblinfun.add_right clinearI tensor_ell2_add1 tensor_ell2_add2 tensor_ell2_scaleC1 tensor_ell2_scaleC2)
apply (simp add: clinearI tensor_ell2_add1 tensor_ell2_add2 tensor_ell2_scaleC1 tensor_ell2_scaleC2)
apply (rule clinear_equal_ket[THEN fun_cong, where x=c])
apply (simp add: cblinfun.add_right clinearI tensor_ell2_add2 tensor_ell2_scaleC2)
apply (simp add: clinearI tensor_ell2_add2 tensor_ell2_scaleC2)
unfolding assoc_ell2.rep_eq
apply transfer
by auto
lemma assoc_ell2'_tensor: ‹assoc_ell2' *⇩V tensor_ell2 a (tensor_ell2 b c) = tensor_ell2 (tensor_ell2 a b) c›
apply (rule clinear_equal_ket[THEN fun_cong, where x=a])
apply (simp add: cblinfun.add_right clinearI tensor_ell2_add1 tensor_ell2_scaleC1)
apply (simp add: clinearI tensor_ell2_add1 tensor_ell2_scaleC1)
apply (rule clinear_equal_ket[THEN fun_cong, where x=b])
apply (simp add: cblinfun.add_right clinearI tensor_ell2_add1 tensor_ell2_add2 tensor_ell2_scaleC1 tensor_ell2_scaleC2)
apply (simp add: clinearI tensor_ell2_add1 tensor_ell2_add2 tensor_ell2_scaleC1 tensor_ell2_scaleC2)
apply (rule clinear_equal_ket[THEN fun_cong, where x=c])
apply (simp add: cblinfun.add_right clinearI tensor_ell2_add2 tensor_ell2_scaleC2)
apply (simp add: clinearI tensor_ell2_add2 tensor_ell2_scaleC2)
unfolding assoc_ell2'.rep_eq
apply transfer
by auto
lemma adjoint_assoc_ell2[simp]: ‹assoc_ell2* = assoc_ell2'›
proof (rule adjoint_eqI[symmetric])
have [simp]: ‹clinear (cinner (assoc_ell2' *⇩V x))› for x :: ‹('a × 'b × 'c) ell2›
by (metis (no_types, lifting) cblinfun.add_right cinner_scaleC_right clinearI complex_scaleC_def mult.comm_neutral of_complex_def vector_to_cblinfun_adj_apply)
have [simp]: ‹clinear (λa. ⟨x, assoc_ell2 *⇩V a⟩)› for x :: ‹('a × 'b × 'c) ell2›
by (simp add: cblinfun.add_right cinner_add_right clinearI)
have [simp]: ‹antilinear (λa. ⟨a, y⟩)› for y :: ‹('a × 'b × 'c) ell2›
using bounded_antilinear_cinner_left bounded_antilinear_def by blast
have [simp]: ‹antilinear (λa. ⟨assoc_ell2' *⇩V a, y⟩)› for y :: ‹(('a × 'b) × 'c) ell2›
by (simp add: cblinfun.add_right cinner_add_left antilinearI)
have ‹⟨assoc_ell2' *⇩V (ket x), ket y⟩ = ⟨ket x, assoc_ell2 *⇩V ket y⟩› for x :: ‹'a × 'b × 'c› and y
apply (cases x, cases y)
by (simp flip: tensor_ell2_ket add: assoc_ell2'_tensor assoc_ell2_tensor)
then have ‹⟨assoc_ell2' *⇩V (ket x), y⟩ = ⟨ket x, assoc_ell2 *⇩V y⟩› for x :: ‹'a × 'b × 'c› and y
by (rule clinear_equal_ket[THEN fun_cong, rotated 2], simp_all)
then show ‹⟨assoc_ell2' *⇩V x, y⟩ = ⟨x, assoc_ell2 *⇩V y⟩› for x :: ‹('a × 'b × 'c) ell2› and y
by (rule antilinear_equal_ket[THEN fun_cong, rotated 2], simp_all)
qed
lemma adjoint_assoc_ell2'[simp]: ‹assoc_ell2'* = assoc_ell2›
by (simp flip: adjoint_assoc_ell2)
lift_definition swap_ell20 :: ‹('a::finite×'b::finite) ell2 ⇒ ('b×'a) ell2› is
‹λf (a,b). f (b,a)›
by auto
lift_definition swap_ell2 :: ‹('a::finite×'b::finite) ell2 ⇒⇩C⇩L ('b×'a) ell2›
is swap_ell20
apply (subst bounded_clinear_finite_dim)
apply (rule clinearI; transfer)
by auto
lemma swap_ell2_tensor[simp]: ‹swap_ell2 *⇩V tensor_ell2 a b = tensor_ell2 b a›
apply (rule clinear_equal_ket[THEN fun_cong, where x=a])
apply (simp add: cblinfun.add_right clinearI tensor_ell2_add1 tensor_ell2_scaleC1)
apply (simp add: clinear_tensor_ell21)
apply (rule clinear_equal_ket[THEN fun_cong, where x=b])
apply (simp add: cblinfun.add_right clinearI tensor_ell2_add1 tensor_ell2_add2 tensor_ell2_scaleC1 tensor_ell2_scaleC2)
apply (simp add: clinearI tensor_ell2_add1 tensor_ell2_add2 tensor_ell2_scaleC1 tensor_ell2_scaleC2)
unfolding swap_ell2.rep_eq
apply transfer
by auto
lemma adjoint_swap_ell2[simp]: ‹swap_ell2* = swap_ell2›
proof (rule adjoint_eqI[symmetric])
have [simp]: ‹clinear (cinner (swap_ell2 *⇩V x))› for x :: ‹('a × 'b) ell2›
by (metis (no_types, lifting) cblinfun.add_right cinner_scaleC_right clinearI complex_scaleC_def mult.comm_neutral of_complex_def vector_to_cblinfun_adj_apply)
have [simp]: ‹clinear (λa. ⟨x, swap_ell2 *⇩V a⟩)› for x :: ‹('a × 'b) ell2›
by (simp add: cblinfun.add_right cinner_add_right clinearI)
have [simp]: ‹antilinear (λa. ⟨a, y⟩)› for y :: ‹('a × 'b) ell2›
using bounded_antilinear_cinner_left bounded_antilinear_def by blast
have [simp]: ‹antilinear (λa. ⟨swap_ell2 *⇩V a, y⟩)› for y :: ‹('b × 'a) ell2›
by (simp add: cblinfun.add_right cinner_add_left antilinearI)
have ‹⟨swap_ell2 *⇩V (ket x), ket y⟩ = ⟨ket x, swap_ell2 *⇩V ket y⟩› for x :: ‹'a × 'b› and y
apply (cases x, cases y)
by (simp flip: tensor_ell2_ket add: swap_ell2_tensor)
then have ‹⟨swap_ell2 *⇩V (ket x), y⟩ = ⟨ket x, swap_ell2 *⇩V y⟩› for x :: ‹'a × 'b› and y
by (rule clinear_equal_ket[THEN fun_cong, rotated 2], simp_all)
then show ‹⟨swap_ell2 *⇩V x, y⟩ = ⟨x, swap_ell2 *⇩V y⟩› for x :: ‹('a × 'b) ell2› and y
apply (rule antilinear_equal_ket[THEN fun_cong, rotated 2])
by simp_all
qed
lemma tensor_ell2_extensionality:
assumes "(⋀s t. a *⇩V (s ⊗⇩s t) = b *⇩V (s ⊗⇩s t))"
shows "a = b"
apply (rule equal_ket, case_tac x, hypsubst_thin)
by (simp add: assms flip: tensor_ell2_ket)
lemma assoc_ell2'_assoc_ell2[simp]: ‹assoc_ell2' o⇩C⇩L assoc_ell2 = id_cblinfun›
by (auto intro!: equal_ket simp: cblinfun_apply_cblinfun_compose assoc_ell2'_tensor assoc_ell2_tensor simp flip: tensor_ell2_ket)
lemma assoc_ell2_assoc_ell2'[simp]: ‹assoc_ell2 o⇩C⇩L assoc_ell2' = id_cblinfun›
by (auto intro!: equal_ket simp: cblinfun_apply_cblinfun_compose assoc_ell2'_tensor assoc_ell2_tensor simp flip: tensor_ell2_ket)
lemma unitary_assoc_ell2[simp]: "unitary assoc_ell2"
unfolding unitary_def by auto
lemma unitary_assoc_ell2'[simp]: "unitary assoc_ell2'"
unfolding unitary_def by auto
lemma tensor_op_left_add: ‹(x + y) ⊗⇩o b = x ⊗⇩o b + y ⊗⇩o b›
for x y :: ‹'a::finite ell2 ⇒⇩C⇩L 'c::finite ell2› and b :: ‹'b::finite ell2 ⇒⇩C⇩L 'd::finite ell2›
apply (auto intro!: equal_ket simp: tensor_op_ket)
by (simp add: plus_cblinfun.rep_eq tensor_ell2_add1 tensor_op_ket)
lemma tensor_op_right_add: ‹b ⊗⇩o (x + y) = b ⊗⇩o x + b ⊗⇩o y›
for x y :: ‹'a::finite ell2 ⇒⇩C⇩L 'c::finite ell2› and b :: ‹'b::finite ell2 ⇒⇩C⇩L 'd::finite ell2›
apply (auto intro!: equal_ket simp: tensor_op_ket)
by (simp add: plus_cblinfun.rep_eq tensor_ell2_add2 tensor_op_ket)
lemma tensor_op_scaleC_left: ‹(c *⇩C x) ⊗⇩o b = c *⇩C (x ⊗⇩o b)›
for x :: ‹'a::finite ell2 ⇒⇩C⇩L 'c::finite ell2› and b :: ‹'b::finite ell2 ⇒⇩C⇩L 'd::finite ell2›
apply (auto intro!: equal_ket simp: tensor_op_ket)
by (metis scaleC_cblinfun.rep_eq tensor_ell2_ket tensor_ell2_scaleC1 tensor_op_ell2)
lemma tensor_op_scaleC_right: ‹b ⊗⇩o (c *⇩C x) = c *⇩C (b ⊗⇩o x)›
for x :: ‹'a::finite ell2 ⇒⇩C⇩L 'c::finite ell2› and b :: ‹'b::finite ell2 ⇒⇩C⇩L 'd::finite ell2›
apply (auto intro!: equal_ket simp: tensor_op_ket)
by (metis scaleC_cblinfun.rep_eq tensor_ell2_ket tensor_ell2_scaleC2 tensor_op_ell2)
lemma clinear_tensor_left[simp]: ‹clinear (λa. a ⊗⇩o b :: _::finite ell2 ⇒⇩C⇩L _::finite ell2)›
apply (rule clinearI)
apply (rule tensor_op_left_add)
by (rule tensor_op_scaleC_left)
lemma clinear_tensor_right[simp]: ‹clinear (λb. a ⊗⇩o b :: _::finite ell2 ⇒⇩C⇩L _::finite ell2)›
apply (rule clinearI)
apply (rule tensor_op_right_add)
by (rule tensor_op_scaleC_right)
lemma tensor_ell2_nonzero: ‹a ⊗⇩s b ≠ 0› if ‹a ≠ 0› and ‹b ≠ 0›
apply (use that in transfer)
apply auto
by (metis mult_eq_0_iff old.prod.case)
lemma tensor_op_nonzero:
fixes a :: ‹'a::finite ell2 ⇒⇩C⇩L 'c::finite ell2› and b :: ‹'b::finite ell2 ⇒⇩C⇩L 'd::finite ell2›
assumes ‹a ≠ 0› and ‹b ≠ 0›
shows ‹a ⊗⇩o b ≠ 0›
proof -
from ‹a ≠ 0› obtain i where i: ‹a *⇩V ket i ≠ 0›
by (metis cblinfun.zero_left equal_ket)
from ‹b ≠ 0› obtain j where j: ‹b *⇩V ket j ≠ 0›
by (metis cblinfun.zero_left equal_ket)
from i j have ijneq0: ‹(a *⇩V ket i) ⊗⇩s (b *⇩V ket j) ≠ 0›
by (simp add: tensor_ell2_nonzero)
have ‹(a *⇩V ket i) ⊗⇩s (b *⇩V ket j) = (a ⊗⇩o b) *⇩V ket (i,j)›
by (simp add: tensor_op_ket)
with ijneq0 show ‹a ⊗⇩o b ≠ 0›
by force
qed
lemma inj_tensor_ell2_left: ‹inj (λa::'a::finite ell2. a ⊗⇩s b)› if ‹b ≠ 0› for b :: ‹'b::finite ell2›
proof (rule injI, rule ccontr)
fix x y :: ‹'a ell2›
assume eq: ‹x ⊗⇩s b = y ⊗⇩s b›
assume neq: ‹x ≠ y›
define a where ‹a = x - y›
from neq a_def have neq0: ‹a ≠ 0›
by auto
with ‹b ≠ 0› have ‹a ⊗⇩s b ≠ 0›
by (simp add: tensor_ell2_nonzero)
then have ‹x ⊗⇩s b ≠ y ⊗⇩s b›
unfolding a_def
by (metis add_cancel_left_left diff_add_cancel tensor_ell2_add1)
with eq show False
by auto
qed
lemma inj_tensor_ell2_right: ‹inj (λb::'b::finite ell2. a ⊗⇩s b)› if ‹a ≠ 0› for a :: ‹'a::finite ell2›
proof (rule injI, rule ccontr)
fix x y :: ‹'b ell2›
assume eq: ‹a ⊗⇩s x = a ⊗⇩s y›
assume neq: ‹x ≠ y›
define b where ‹b = x - y›
from neq b_def have neq0: ‹b ≠ 0›
by auto
with ‹a ≠ 0› have ‹a ⊗⇩s b ≠ 0›
by (simp add: tensor_ell2_nonzero)
then have ‹a ⊗⇩s x ≠ a ⊗⇩s y›
unfolding b_def
by (metis add_cancel_left_left diff_add_cancel tensor_ell2_add2)
with eq show False
by auto
qed
lemma inj_tensor_left: ‹inj (λa::'a::finite ell2 ⇒⇩C⇩L 'c::finite ell2. a ⊗⇩o b)› if ‹b ≠ 0› for b :: ‹'b::finite ell2 ⇒⇩C⇩L 'd::finite ell2›
proof (rule injI, rule ccontr)
fix x y :: ‹'a ell2 ⇒⇩C⇩L 'c ell2›
assume eq: ‹x ⊗⇩o b = y ⊗⇩o b›
assume neq: ‹x ≠ y›
define a where ‹a = x - y›
from neq a_def have neq0: ‹a ≠ 0›
by auto
with ‹b ≠ 0› have ‹a ⊗⇩o b ≠ 0›
by (simp add: tensor_op_nonzero)
then have ‹x ⊗⇩o b ≠ y ⊗⇩o b›
unfolding a_def
by (metis add_cancel_left_left diff_add_cancel tensor_op_left_add)
with eq show False
by auto
qed
lemma inj_tensor_right: ‹inj (λb::'b::finite ell2 ⇒⇩C⇩L 'c::finite ell2. a ⊗⇩o b)› if ‹a ≠ 0› for a :: ‹'a::finite ell2 ⇒⇩C⇩L 'd::finite ell2›
proof (rule injI, rule ccontr)
fix x y :: ‹'b ell2 ⇒⇩C⇩L 'c ell2›
assume eq: ‹a ⊗⇩o x = a ⊗⇩o y›
assume neq: ‹x ≠ y›
define b where ‹b = x - y›
from neq b_def have neq0: ‹b ≠ 0›
by auto
with ‹a ≠ 0› have ‹a ⊗⇩o b ≠ 0›
by (simp add: tensor_op_nonzero)
then have ‹a ⊗⇩o x ≠ a ⊗⇩o y›
unfolding b_def
by (metis add_cancel_left_left diff_add_cancel tensor_op_right_add)
with eq show False
by auto
qed
lemma tensor_ell2_almost_injective:
assumes ‹tensor_ell2 a b = tensor_ell2 c d›
assumes ‹a ≠ 0›
shows ‹∃γ. b = γ *⇩C d›
proof -
from ‹a ≠ 0› obtain i where i: ‹cinner (ket i) a ≠ 0›
by (metis cinner_eq_zero_iff cinner_ket_left ell2_pointwise_ortho)
have ‹cinner (ket i ⊗⇩s ket j) (a ⊗⇩s b) = cinner (ket i ⊗⇩s ket j) (c ⊗⇩s d)› for j
using assms by simp
then have eq2: ‹(cinner (ket i) a) * (cinner (ket j) b) = (cinner (ket i) c) * (cinner (ket j) d)› for j
by (metis tensor_ell2_inner_prod)
then obtain γ where ‹cinner (ket i) c = γ * cinner (ket i) a›
by (metis i eq_divide_eq)
with eq2 have ‹(cinner (ket i) a) * (cinner (ket j) b) = (cinner (ket i) a) * (γ * cinner (ket j) d)› for j
by simp
then have ‹cinner (ket j) b = cinner (ket j) (γ *⇩C d)› for j
using i by force
then have ‹b = γ *⇩C d›
by (simp add: cinner_ket_eqI)
then show ?thesis
by auto
qed
lemma tensor_op_almost_injective:
fixes a c :: ‹'a::finite ell2 ⇒⇩C⇩L 'b::finite ell2›
and b d :: ‹'c::finite ell2 ⇒⇩C⇩L 'd::finite ell2›
assumes ‹tensor_op a b = tensor_op c d›
assumes ‹a ≠ 0›
shows ‹∃γ. b = γ *⇩C d›
proof (cases ‹d = 0›)
case False
from ‹a ≠ 0› obtain ψ where ψ: ‹a *⇩V ψ ≠ 0›
by (metis cblinfun.zero_left cblinfun_eqI)
have ‹(a ⊗⇩o b) (ψ ⊗⇩s φ) = (c ⊗⇩o d) (ψ ⊗⇩s φ)› for φ
using assms by simp
then have eq2: ‹(a ψ) ⊗⇩s (b φ) = (c ψ) ⊗⇩s (d φ)› for φ
by (simp add: tensor_op_ell2)
then have eq2': ‹(d φ) ⊗⇩s (c ψ) = (b φ) ⊗⇩s (a ψ)› for φ
by (metis swap_ell2_tensor)
from False obtain φ0 where φ0: ‹d φ0 ≠ 0›
by (metis cblinfun.zero_left cblinfun_eqI)
obtain γ where ‹c ψ = γ *⇩C a ψ›
apply atomize_elim
using eq2' φ0 by (rule tensor_ell2_almost_injective)
with eq2 have ‹(a ψ) ⊗⇩s (b φ) = (a ψ) ⊗⇩s (γ *⇩C d φ)› for φ
by (simp add: tensor_ell2_scaleC1 tensor_ell2_scaleC2)
then have ‹b φ = γ *⇩C d φ› for φ
by (smt (verit, best) ψ complex_vector.scale_cancel_right tensor_ell2_almost_injective tensor_ell2_nonzero tensor_ell2_scaleC2)
then have ‹b = γ *⇩C d›
by (simp add: cblinfun_eqI)
then show ?thesis
by auto
next
case True
then have ‹c ⊗⇩o d = 0›
by (metis add_cancel_right_left tensor_op_right_add)
then have ‹a ⊗⇩o b = 0›
using assms(1) by presburger
with ‹a ≠ 0› have ‹b = 0›
by (meson tensor_op_nonzero)
then show ?thesis
by auto
qed
lemma tensor_ell2_0_left[simp]: ‹tensor_ell2 0 x = 0›
apply transfer by auto
lemma tensor_ell2_0_right[simp]: ‹tensor_ell2 x 0 = 0›
apply transfer by auto
lemma tensor_op_0_left[simp]: ‹tensor_op 0 x = (0 :: ('a::finite*'b::finite) ell2 ⇒⇩C⇩L ('c::finite*'d::finite) ell2)›
apply (rule equal_ket)
by (auto simp flip: tensor_ell2_ket simp: tensor_op_ell2)
lemma tensor_op_0_right[simp]: ‹tensor_op x 0 = (0 :: ('a::finite*'b::finite) ell2 ⇒⇩C⇩L ('c::finite*'d::finite) ell2)›
apply (rule equal_ket)
by (auto simp flip: tensor_ell2_ket simp: tensor_op_ell2)
lemma bij_tensor_ell2_one_dim_left:
assumes ‹ψ ≠ 0›
shows ‹bij (λx::'b::finite ell2. (ψ :: 'a::CARD_1 ell2) ⊗⇩s x)›
proof (rule bijI)
show ‹inj (λx::'b::finite ell2. (ψ :: 'a::CARD_1 ell2) ⊗⇩s x)›
using assms by (rule inj_tensor_ell2_right)
have ‹∃x. ψ ⊗⇩s x = φ› for φ :: ‹('a*'b) ell2›
proof (use assms in transfer)
fix ψ :: ‹'a ⇒ complex› and φ :: ‹'a*'b ⇒ complex›
assume ‹has_ell2_norm φ› and ‹ψ ≠ (λ_. 0)›
define c where ‹c = ψ undefined›
then have ‹ψ a = c› for a
apply (subst everything_the_same[of _ undefined])
by simp
with ‹ψ ≠ (λ_. 0)› have ‹c ≠ 0›
by auto
define x where ‹x j = φ (undefined, j) / c› for j
have ‹(λ(i, j). ψ i * x j) = φ›
apply (auto intro!: ext simp: x_def ‹ψ _ = c› ‹c ≠ 0›)
apply (subst (2) everything_the_same[of _ undefined])
by simp
then show ‹∃x∈Collect has_ell2_norm. (λ(i, j). ψ i * x j) = φ›
apply (rule bexI[where x=x])
by simp
qed
then show ‹surj (λx::'b::finite ell2. (ψ :: 'a::CARD_1 ell2) ⊗⇩s x)›
by (metis surj_def)
qed
lemma bij_tensor_op_one_dim_left:
assumes ‹a ≠ 0›
shows ‹bij (λx::'c::finite ell2 ⇒⇩C⇩L 'd::finite ell2. (a :: 'a::{CARD_1,enum} ell2 ⇒⇩C⇩L 'b::{CARD_1,enum} ell2) ⊗⇩o x)›
proof (rule bijI)
define t where ‹t = (λx::'c ell2 ⇒⇩C⇩L 'd ell2. (a :: 'a ell2 ⇒⇩C⇩L 'b ell2) ⊗⇩o x)›
define i where
‹i = tensor_lift (λ(x::'a ell2 ⇒⇩C⇩L 'b ell2) (y::'c ell2 ⇒⇩C⇩L 'd ell2). (one_dim_iso x / one_dim_iso a) *⇩C y)›
have [simp]: ‹clinear i›
by (auto intro!: tensor_lift_clinear simp: i_def cbilinear_def clinearI scaleC_add_left add_divide_distrib)
have [simp]: ‹clinear t›
by (simp add: t_def)
have ‹i (x ⊗⇩o y) = (one_dim_iso x / one_dim_iso a) *⇩C y› for x y
by (auto intro!: clinearI tensor_lift_correct[THEN fun_cong, THEN fun_cong] simp: t_def i_def cbilinear_def scaleC_add_left add_divide_distrib)
then have ‹t (i (x ⊗⇩o y)) = x ⊗⇩o y› for x y
apply (simp add: t_def)
by (smt (z3) assms complex_vector.scale_eq_0_iff nonzero_mult_div_cancel_right one_dim_scaleC_1 scaleC_scaleC tensor_op_scaleC_left tensor_op_scaleC_right times_divide_eq_left)
then have ‹t (i x) = x› for x
apply (rule_tac fun_cong[where x=x])
apply (rule tensor_extensionality)
by (auto intro: clinear_compose complex_vector.module_hom_ident simp flip: o_def[of t i])
then show ‹surj t›
by (rule surjI)
show ‹inj t›
unfolding t_def using assms by (rule inj_tensor_right)
qed
lemma swap_ell2_selfinv[simp]: ‹swap_ell2 o⇩C⇩L swap_ell2 = id_cblinfun›
apply (rule tensor_ell2_extensionality)
by auto
lemma bij_tensor_op_one_dim_right:
assumes ‹b ≠ 0›
shows ‹bij (λx::'c::finite ell2 ⇒⇩C⇩L 'd::finite ell2. x ⊗⇩o (b :: 'a::{CARD_1,enum} ell2 ⇒⇩C⇩L 'b::{CARD_1,enum} ell2))›
(is ‹bij ?f›)
proof -
let ?sf = ‹(λx. swap_ell2 o⇩C⇩L (?f x) o⇩C⇩L swap_ell2)›
let ?s = ‹(λx. swap_ell2 o⇩C⇩L x o⇩C⇩L swap_ell2)›
let ?g = ‹(λx::'c::finite ell2 ⇒⇩C⇩L 'd::finite ell2. (b :: 'a::{CARD_1,enum} ell2 ⇒⇩C⇩L 'b::{CARD_1,enum} ell2) ⊗⇩o x)›
have ‹?sf = ?g›
by (auto intro!: ext tensor_ell2_extensionality simp add: swap_ell2_tensor tensor_op_ell2)
have ‹bij ?g›
using assms by (rule bij_tensor_op_one_dim_left)
have ‹?s o ?sf = ?f›
apply (auto intro!: ext simp: cblinfun_assoc_left)
by (auto simp: cblinfun_assoc_right)
also have ‹bij ?s›
apply (rule o_bij[where g=‹(λx. swap_ell2 o⇩C⇩L x o⇩C⇩L swap_ell2)›])
apply (auto intro!: ext simp: cblinfun_assoc_left)
by (auto simp: cblinfun_assoc_right)
show ‹bij ?f›
apply (subst ‹?s o ?sf = ?f›[symmetric], subst ‹?sf = ?g›)
using ‹bij ?g› ‹bij ?s› by (rule bij_comp)
qed
lemma overlapping_tensor:
fixes a23 :: ‹('a2::finite*'a3::finite) ell2 ⇒⇩C⇩L ('b2::finite*'b3::finite) ell2›
and b12 :: ‹('a1::finite*'a2) ell2 ⇒⇩C⇩L ('b1::finite*'b2) ell2›
assumes eq: ‹butterfly ψ ψ' ⊗⇩o a23 = assoc_ell2 o⇩C⇩L (b12 ⊗⇩o butterfly φ φ') o⇩C⇩L assoc_ell2'›
assumes ‹ψ ≠ 0› ‹ψ' ≠ 0› ‹φ ≠ 0› ‹φ' ≠ 0›
shows ‹∃c. butterfly ψ ψ' ⊗⇩o a23 = butterfly ψ ψ' ⊗⇩o c ⊗⇩o butterfly φ φ'›
proof -
note [[show_types]]
let ?id1 = ‹id_cblinfun :: unit ell2 ⇒⇩C⇩L unit ell2›
note id_cblinfun_eq_1[simp del]
define d where ‹d = butterfly ψ ψ' ⊗⇩o a23›
define ψ⇩n ψ⇩n' a23⇩n where ‹ψ⇩n = ψ /⇩C norm ψ› and ‹ψ⇩n' = ψ' /⇩C norm ψ'› and ‹a23⇩n = norm ψ *⇩C norm ψ' *⇩C a23›
have [simp]: ‹norm ψ⇩n = 1› ‹norm ψ⇩n' = 1›
using ‹ψ ≠ 0› ‹ψ' ≠ 0› by (auto simp: ψ⇩n_def ψ⇩n'_def norm_inverse)
have n1: ‹butterfly ψ⇩n ψ⇩n' ⊗⇩o a23⇩n = butterfly ψ ψ' ⊗⇩o a23›
apply (auto simp: ψ⇩n_def ψ⇩n'_def a23⇩n_def tensor_op_scaleC_left tensor_op_scaleC_right)
by (metis (no_types, lifting) assms(2) assms(3) inverse_mult_distrib mult.commute no_zero_divisors norm_eq_zero of_real_eq_0_iff right_inverse scaleC_one)
define φ⇩n φ⇩n' b12⇩n where ‹φ⇩n = φ /⇩C norm φ› and ‹φ⇩n' = φ' /⇩C norm φ'› and ‹b12⇩n = norm φ *⇩C norm φ' *⇩C b12›
have [simp]: ‹norm φ⇩n = 1› ‹norm φ⇩n' = 1›
using ‹φ ≠ 0› ‹φ' ≠ 0› by (auto simp: φ⇩n_def φ⇩n'_def norm_inverse)
have n2: ‹b12⇩n ⊗⇩o butterfly φ⇩n φ⇩n' = b12 ⊗⇩o butterfly φ φ'›
apply (auto simp: φ⇩n_def φ⇩n'_def b12⇩n_def tensor_op_scaleC_left tensor_op_scaleC_right)
by (metis (no_types, lifting) assms(4) assms(5) field_class.field_inverse inverse_mult_distrib mult.commute no_zero_divisors norm_eq_zero of_real_hom.hom_0 scaleC_one)
define c' :: ‹(unit*'a2*unit) ell2 ⇒⇩C⇩L (unit*'b2*unit) ell2›
where ‹c' = (vector_to_cblinfun ψ⇩n ⊗⇩o id_cblinfun ⊗⇩o vector_to_cblinfun φ⇩n)* o⇩C⇩L d
o⇩C⇩L (vector_to_cblinfun ψ⇩n' ⊗⇩o id_cblinfun ⊗⇩o vector_to_cblinfun φ⇩n')›
define c'' :: ‹'a2 ell2 ⇒⇩C⇩L 'b2 ell2›
where ‹c'' = inv (λc''. id_cblinfun ⊗⇩o c'' ⊗⇩o id_cblinfun) c'›
have *: ‹bij (λc''::'a2 ell2 ⇒⇩C⇩L 'b2 ell2. ?id1 ⊗⇩o c'' ⊗⇩o ?id1)›
apply (subst asm_rl[of ‹_ = (λx. id_cblinfun ⊗⇩o x) o (λc''. c'' ⊗⇩o id_cblinfun)›])
using [[show_consts]]
by (auto intro!: bij_comp bij_tensor_op_one_dim_left bij_tensor_op_one_dim_right)
have c'_c'': ‹c' = ?id1 ⊗⇩o c'' ⊗⇩o ?id1›
unfolding c''_def
apply (rule surj_f_inv_f[where y=c', symmetric])
using * by (rule bij_is_surj)
define c :: ‹'a2 ell2 ⇒⇩C⇩L 'b2 ell2›
where ‹c = c'' /⇩C norm ψ /⇩C norm ψ' /⇩C norm φ /⇩C norm φ'›
have aux: ‹assoc_ell2' o⇩C⇩L (assoc_ell2 o⇩C⇩L x o⇩C⇩L assoc_ell2') o⇩C⇩L assoc_ell2 = x› for x
apply (simp add: cblinfun_assoc_left)
by (simp add: cblinfun_assoc_right)
have aux2: ‹(assoc_ell2 o⇩C⇩L ((x ⊗⇩o y) ⊗⇩o z) o⇩C⇩L assoc_ell2') = x ⊗⇩o (y ⊗⇩o z)› for x y z
apply (rule equal_ket, rename_tac xyz)
apply (case_tac xyz, hypsubst_thin)
by (simp flip: tensor_ell2_ket add: assoc_ell2'_tensor assoc_ell2_tensor tensor_op_ell2)
have ‹d = (butterfly ψ⇩n ψ⇩n ⊗⇩o id_cblinfun) o⇩C⇩L d o⇩C⇩L (butterfly ψ⇩n' ψ⇩n' ⊗⇩o id_cblinfun)›
by (auto simp: d_def n1[symmetric] comp_tensor_op cnorm_eq_1[THEN iffD1])
also have ‹… = (butterfly ψ⇩n ψ⇩n ⊗⇩o id_cblinfun) o⇩C⇩L assoc_ell2 o⇩C⇩L (b12⇩n ⊗⇩o butterfly φ⇩n φ⇩n')
o⇩C⇩L assoc_ell2' o⇩C⇩L (butterfly ψ⇩n' ψ⇩n' ⊗⇩o id_cblinfun)›
by (auto simp: d_def eq n2 cblinfun_assoc_left)
also have ‹… = (butterfly ψ⇩n ψ⇩n ⊗⇩o id_cblinfun) o⇩C⇩L assoc_ell2 o⇩C⇩L
((id_cblinfun ⊗⇩o butterfly φ⇩n φ⇩n) o⇩C⇩L (b12⇩n ⊗⇩o butterfly φ⇩n φ⇩n') o⇩C⇩L (id_cblinfun ⊗⇩o butterfly φ⇩n' φ⇩n'))
o⇩C⇩L assoc_ell2' o⇩C⇩L (butterfly ψ⇩n' ψ⇩n' ⊗⇩o id_cblinfun)›
by (auto simp: comp_tensor_op cnorm_eq_1[THEN iffD1])
also have ‹… = (butterfly ψ⇩n ψ⇩n ⊗⇩o id_cblinfun) o⇩C⇩L assoc_ell2 o⇩C⇩L
((id_cblinfun ⊗⇩o butterfly φ⇩n φ⇩n) o⇩C⇩L (assoc_ell2' o⇩C⇩L d o⇩C⇩L assoc_ell2) o⇩C⇩L (id_cblinfun ⊗⇩o butterfly φ⇩n' φ⇩n'))
o⇩C⇩L assoc_ell2' o⇩C⇩L (butterfly ψ⇩n' ψ⇩n' ⊗⇩o id_cblinfun)›
by (auto simp: d_def n2 eq aux)
also have ‹… = ((butterfly ψ⇩n ψ⇩n ⊗⇩o id_cblinfun) o⇩C⇩L (assoc_ell2 o⇩C⇩L (id_cblinfun ⊗⇩o butterfly φ⇩n φ⇩n) o⇩C⇩L assoc_ell2'))
o⇩C⇩L d o⇩C⇩L ((assoc_ell2 o⇩C⇩L (id_cblinfun ⊗⇩o butterfly φ⇩n' φ⇩n') o⇩C⇩L assoc_ell2') o⇩C⇩L (butterfly ψ⇩n' ψ⇩n' ⊗⇩o id_cblinfun))›
by (auto simp: sandwich_def cblinfun_assoc_left)
also have ‹… = (butterfly ψ⇩n ψ⇩n ⊗⇩o id_cblinfun ⊗⇩o butterfly φ⇩n φ⇩n)
o⇩C⇩L d o⇩C⇩L (butterfly ψ⇩n' ψ⇩n' ⊗⇩o id_cblinfun ⊗⇩o butterfly φ⇩n' φ⇩n')›
apply (simp only: tensor_id[symmetric] comp_tensor_op aux2)
by (simp add: cnorm_eq_1[THEN iffD1])
also have ‹… = (vector_to_cblinfun ψ⇩n ⊗⇩o id_cblinfun ⊗⇩o vector_to_cblinfun φ⇩n)
o⇩C⇩L c' o⇩C⇩L (vector_to_cblinfun ψ⇩n' ⊗⇩o id_cblinfun ⊗⇩o vector_to_cblinfun φ⇩n')*›
apply (simp add: c'_def butterfly_def_one_dim[where 'c="unit ell2"] cblinfun_assoc_left comp_tensor_op
tensor_op_adjoint cnorm_eq_1[THEN iffD1])
by (simp add: cblinfun_assoc_right comp_tensor_op)
also have ‹… = butterfly ψ⇩n ψ⇩n' ⊗⇩o c'' ⊗⇩o butterfly φ⇩n φ⇩n'›
by (simp add: c'_c'' comp_tensor_op tensor_op_adjoint butterfly_def_one_dim[symmetric])
also have ‹… = butterfly ψ ψ' ⊗⇩o c ⊗⇩o butterfly φ φ'›
by (simp add: ψ⇩n_def ψ⇩n'_def φ⇩n_def φ⇩n'_def c_def tensor_op_scaleC_left tensor_op_scaleC_right)
finally have d_c: ‹d = butterfly ψ ψ' ⊗⇩o c ⊗⇩o butterfly φ φ'›
by -
then show ?thesis
by (auto simp: d_def)
qed
lemma norm_tensor_ell2: ‹norm (a ⊗⇩s b) = norm a * norm b›
apply transfer
by (simp add: ell2_norm_finite sum_product sum.cartesian_product case_prod_beta
norm_mult power_mult_distrib flip: real_sqrt_mult)
lemma bounded_cbilinear_tensor_ell2[bounded_cbilinear]: ‹bounded_cbilinear (⊗⇩s)›
proof standard
fix a a' :: "'a ell2" and b b' :: "'b ell2" and r :: complex
show ‹tensor_ell2 (a + a') b = tensor_ell2 a b + tensor_ell2 a' b›
by (meson tensor_ell2_add1)
show ‹tensor_ell2 a (b + b') = tensor_ell2 a b + tensor_ell2 a b'›
by (simp add: tensor_ell2_add2)
show ‹tensor_ell2 (r *⇩C a) b = r *⇩C tensor_ell2 a b›
by (simp add: tensor_ell2_scaleC1)
show ‹tensor_ell2 a (r *⇩C b) = r *⇩C tensor_ell2 a b›
by (simp add: tensor_ell2_scaleC2)
show ‹∃K. ∀a b. norm (tensor_ell2 a b) ≤ norm a * norm b * K ›
apply (rule exI[of _ 1])
by (simp add: norm_tensor_ell2)
qed
end
Theory Axioms_Quantum
section ‹Quantum instantiation of registers›
theory Axioms_Quantum
imports Jordan_Normal_Form.Matrix_Impl "HOL-Library.Rewrite"
Complex_Bounded_Operators.Complex_L2
Finite_Tensor_Product
begin
unbundle cblinfun_notation
no_notation m_inv ("invı _" [81] 80)
type_synonym 'a update = ‹('a ell2, 'a ell2) cblinfun›
lemma preregister_mult_right: ‹clinear (λa. a o⇩C⇩L z)›
by (simp add: bounded_cbilinear.add_left bounded_cbilinear_cblinfun_compose clinearI)
lemma preregister_mult_left: ‹clinear (λa. z o⇩C⇩L a)›
by (meson cbilinear_cblinfun_compose cbilinear_def)
definition register :: ‹('a::finite update ⇒ 'b::finite update) ⇒ bool› where
"register F ⟷
clinear F
∧ F id_cblinfun = id_cblinfun
∧ (∀a b. F(a o⇩C⇩L b) = F a o⇩C⇩L F b)
∧ (∀a. F (a*) = (F a)*)"
lemma register_of_id: ‹register F ⟹ F id_cblinfun = id_cblinfun›
by (simp add: register_def)
lemma register_id: ‹register id›
by (simp add: register_def complex_vector.module_hom_id)
lemma register_preregister: "register F ⟹ clinear F"
unfolding register_def by simp
lemma register_comp: "register F ⟹ register G ⟹ register (G ∘ F)"
unfolding register_def
apply auto
using clinear_compose by blast
lemma register_mult: "register F ⟹ cblinfun_compose (F a) (F b) = F (cblinfun_compose a b)"
unfolding register_def
by auto
lemma register_tensor_left: ‹register (λa. tensor_op a id_cblinfun)›
by (simp add: comp_tensor_op register_def tensor_op_cbilinear tensor_op_adjoint)
lemma register_tensor_right: ‹register (λa. tensor_op id_cblinfun a)›
by (simp add: comp_tensor_op register_def tensor_op_cbilinear tensor_op_adjoint)
definition register_pair ::
‹('a::finite update ⇒ 'c::finite update) ⇒ ('b::finite update ⇒ 'c update)
⇒ (('a×'b) update ⇒ 'c update)› where
‹register_pair F G = tensor_lift (λa b. F a o⇩C⇩L G b)›
lemma cbilinear_F_comp_G[simp]: ‹clinear F ⟹ clinear G ⟹ cbilinear (λa b. F a o⇩C⇩L G b)›
unfolding cbilinear_def
by (auto simp add: clinear_iff bounded_cbilinear.add_left bounded_cbilinear_cblinfun_compose bounded_cbilinear.add_right)
lemma register_pair_apply:
assumes ‹register F› and ‹register G›
assumes ‹⋀a b. F a o⇩C⇩L G b = G b o⇩C⇩L F a›
shows ‹(register_pair F G) (tensor_op a b) = F a o⇩C⇩L G b›
unfolding register_pair_def
apply (subst tensor_lift_correct[THEN fun_cong, THEN fun_cong])
apply (rule cbilinear_F_comp_G)
using assms apply (auto intro!: cbilinear_F_comp_G)
using register_def by auto
lemma register_pair_is_register:
fixes F :: ‹'a::finite update ⇒ 'c::finite update› and G
assumes [simp]: ‹register F› and [simp]: ‹register G›
assumes ‹⋀a b. F a o⇩C⇩L G b = G b o⇩C⇩L F a›
shows ‹register (register_pair F G)›
proof (unfold register_def, intro conjI allI)
have [simp]: ‹clinear F› ‹clinear G›
using assms register_def by blast+
have [simp]: ‹F id_cblinfun = id_cblinfun› ‹G id_cblinfun = id_cblinfun›
using assms(1,2) register_def by blast+
show [simp]: ‹clinear (register_pair F G)›
unfolding register_pair_def apply (rule tensor_lift_clinear)
by simp
show ‹register_pair F G id_cblinfun = id_cblinfun›
apply (simp flip: tensor_id)
apply (subst register_pair_apply)
using assms by simp_all
have [simp]: ‹clinear (λy. register_pair F G (x o⇩C⇩L y))› for x :: ‹('a×'b) update›
apply (rule clinear_compose[unfolded o_def, where g=‹register_pair F G›])
by (simp_all add: preregister_mult_left bounded_cbilinear.add_right clinearI)
have [simp]: ‹clinear (λy. x o⇩C⇩L register_pair F G y)› for x :: ‹'c update›
apply (rule clinear_compose[unfolded o_def, where f=‹register_pair F G›])
by (simp_all add: preregister_mult_left bounded_cbilinear.add_right clinearI)
have [simp]: ‹clinear (λx. register_pair F G (x o⇩C⇩L y))› for y :: ‹('a×'b) update›
apply (rule clinear_compose[unfolded o_def, where g=‹register_pair F G›])
by (simp_all add: bounded_cbilinear.add_left bounded_cbilinear_cblinfun_compose clinearI)
have [simp]: ‹clinear (λx. register_pair F G x o⇩C⇩L y)› for y :: ‹'c update›
apply (rule clinear_compose[unfolded o_def, where f=‹register_pair F G›])
by (simp_all add: bounded_cbilinear.add_left bounded_cbilinear_cblinfun_compose clinearI)
have [simp]: ‹F (x o⇩C⇩L y) = F x o⇩C⇩L F y› for x y
by (simp add: register_mult)
have [simp]: ‹G (x o⇩C⇩L y) = G x o⇩C⇩L G y› for x y
by (simp add: register_mult)
have [simp]: ‹clinear (λa. (register_pair F G (a*))*)›
apply (rule antilinear_o_antilinear[unfolded o_def, where f=‹adj›])
apply simp
apply (rule antilinear_o_clinear[unfolded o_def, where g=‹adj›])
by (simp_all)
have [simp]: ‹F (a*) = (F a)*› for a
using assms(1) register_def by blast
have [simp]: ‹G (b*) = (G b)*› for b
using assms(2) register_def by blast
fix a b
show ‹register_pair F G (a o⇩C⇩L b) = register_pair F G a o⇩C⇩L register_pair F G b›
apply (rule tensor_extensionality[THEN fun_cong, where x=b], simp_all)
apply (rule tensor_extensionality[THEN fun_cong, where x=a], simp_all)
apply (simp_all add: comp_tensor_op register_pair_apply assms(3))
using assms(3)
by (metis cblinfun_compose_assoc)
have ‹(register_pair F G (a*))* = register_pair F G a›
apply (rule tensor_extensionality[THEN fun_cong, where x=a])
by (simp_all add: tensor_op_adjoint register_pair_apply assms(3))
then show ‹register_pair F G (a*) = register_pair F G a*›
by (metis double_adj)
qed
end
Theory Laws_Quantum
section ‹Generic laws about registers, instantiated quantumly›
theory Laws_Quantum
imports Axioms_Quantum
begin
text ‹This notation is only used inside this file›
notation cblinfun_compose (infixl "*⇩u" 55)
notation tensor_op (infixr "⊗⇩u" 70)
notation register_pair ("'(_;_')")
subsection ‹Elementary facts›
declare complex_vector.linear_id[simp]
declare cblinfun_compose_id_left[simp]
declare cblinfun_compose_id_right[simp]
declare register_preregister[simp]
declare register_comp[simp]
declare register_of_id[simp]
declare register_tensor_left[simp]
declare register_tensor_right[simp]
declare preregister_mult_right[simp]
declare preregister_mult_left[simp]
declare register_id[simp]
subsection ‹Preregisters›
lemma preregister_tensor_left[simp]: ‹clinear (λb::'b::finite update. tensor_op a b)›
for a :: ‹'a::finite update›
proof -
have ‹clinear ((λb1::('a×'b) update. (a ⊗⇩u id_cblinfun) *⇩u b1) o (λb. tensor_op id_cblinfun b))›
by (rule clinear_compose; simp)
then show ?thesis
by (simp add: o_def comp_tensor_op)
qed
lemma preregister_tensor_right[simp]: ‹clinear (λa::'a::finite update. tensor_op a b)›
for b :: ‹'b::finite update›
proof -
have ‹clinear ((λa1::('a×'b) update. (id_cblinfun ⊗⇩u b) *⇩u a1) o (λa. tensor_op a id_cblinfun))›
by (rule clinear_compose, simp_all)
then show ?thesis
by (simp add: o_def comp_tensor_op)
qed
subsection ‹Registers›
lemma id_update_tensor_register[simp]:
assumes ‹register F›
shows ‹register (λa::'a::finite update. id_cblinfun ⊗⇩u F a)›
using assms apply (rule register_comp[unfolded o_def])
by simp
lemma register_tensor_id_update[simp]:
assumes ‹register F›
shows ‹register (λa::'a::finite update. F a ⊗⇩u id_cblinfun)›
using assms apply (rule register_comp[unfolded o_def])
by simp
subsection ‹Tensor product of registers›
definition register_tensor (infixr "⊗⇩r" 70) where
"register_tensor F G = register_pair (λa. tensor_op (F a) id_cblinfun) (λb. tensor_op id_cblinfun (G b))"
lemma register_tensor_is_register:
fixes F :: "'a::finite update ⇒ 'b::finite update" and G :: "'c::finite update ⇒ 'd::finite update"
shows "register F ⟹ register G ⟹ register (F ⊗⇩r G)"
unfolding register_tensor_def
apply (rule register_pair_is_register)
by (simp_all add: comp_tensor_op)
lemma register_tensor_apply[simp]:
fixes F :: "'a::finite update ⇒ 'b::finite update" and G :: "'c::finite update ⇒ 'd::finite update"
assumes ‹register F› and ‹register G›
shows "(F ⊗⇩r G) (a ⊗⇩u b) = F a ⊗⇩u G b"
unfolding register_tensor_def
apply (subst register_pair_apply)
unfolding register_tensor_def
by (simp_all add: assms comp_tensor_op)
definition "separating (_::'b::finite itself) A ⟷
(∀F G :: 'a::finite update ⇒ 'b update. clinear F ⟶ clinear G ⟶ (∀x∈A. F x = G x) ⟶ F = G)"
lemma separating_UNIV[simp]: ‹separating TYPE(_) UNIV›
unfolding separating_def by auto
lemma separating_mono: ‹A ⊆ B ⟹ separating TYPE('a::finite) A ⟹ separating TYPE('a) B›
unfolding separating_def by (meson in_mono)
lemma register_eqI: ‹separating TYPE('b::finite) A ⟹ clinear F ⟹ clinear G ⟹ (⋀x. x∈A ⟹ F x = G x) ⟹ F = (G::_ ⇒ 'b update)›
unfolding separating_def by auto
lemma separating_tensor:
fixes A :: ‹'a::finite update set› and B :: ‹'b::finite update set›
assumes [simp]: ‹separating TYPE('c::finite) A›
assumes [simp]: ‹separating TYPE('c) B›
shows ‹separating TYPE('c) {a ⊗⇩u b | a b. a∈A ∧ b∈B}›
proof (unfold separating_def, intro allI impI)
fix F G :: ‹('a×'b) update ⇒ 'c update›
assume [simp]: ‹clinear F› ‹clinear G›
have [simp]: ‹clinear (λx. F (a ⊗⇩u x))› for a
using _ ‹clinear F› apply (rule clinear_compose[unfolded o_def])
by simp
have [simp]: ‹clinear (λx. G (a ⊗⇩u x))› for a
using _ ‹clinear G› apply (rule clinear_compose[unfolded o_def])
by simp
have [simp]: ‹clinear (λx. F (x ⊗⇩u b))› for b
using _ ‹clinear F› apply (rule clinear_compose[unfolded o_def])
by simp
have [simp]: ‹clinear (λx. G (x ⊗⇩u b))› for b
using _ ‹clinear G› apply (rule clinear_compose[unfolded o_def])
by simp
assume ‹∀x∈{a ⊗⇩u b |a b. a∈A ∧ b∈B}. F x = G x›
then have EQ: ‹F (a ⊗⇩u b) = G (a ⊗⇩u b)› if ‹a ∈ A› and ‹b ∈ B› for a b
using that by auto
then have ‹F (a ⊗⇩u b) = G (a ⊗⇩u b)› if ‹a ∈ A› for a b
apply (rule register_eqI[where A=B, THEN fun_cong, where x=b, rotated -1])
using that by auto
then have ‹F (a ⊗⇩u b) = G (a ⊗⇩u b)› for a b
apply (rule register_eqI[where A=A, THEN fun_cong, where x=a, rotated -1])
by auto
then show "F = G"
apply (rule tensor_extensionality[rotated -1])
by auto
qed
lemma register_tensor_distrib:
assumes [simp]: ‹register F› ‹register G› ‹register H› ‹register L›
shows ‹(F ⊗⇩r G) o (H ⊗⇩r L) = (F o H) ⊗⇩r (G o L)›
apply (rule tensor_extensionality)
by (auto intro!: register_comp register_preregister register_tensor_is_register)
text ‹The following is easier to apply using the @{method rule}-method than @{thm [source] separating_tensor}›
lemma separating_tensor':
fixes A :: ‹'a::finite update set› and B :: ‹'b::finite update set›
assumes ‹separating TYPE('c::finite) A›
assumes ‹separating TYPE('c) B›
assumes ‹C = {a ⊗⇩u b | a b. a∈A ∧ b∈B}›
shows ‹separating TYPE('c) C›
using assms
by (simp add: separating_tensor)
lemma tensor_extensionality3:
fixes F G :: ‹('a::finite×'b::finite×'c::finite) update ⇒ 'd::finite update›
assumes [simp]: ‹register F› ‹register G›
assumes "⋀f g h. F (f ⊗⇩u g ⊗⇩u h) = G (f ⊗⇩u g ⊗⇩u h)"
shows "F = G"
proof (rule register_eqI[where A=‹{a⊗⇩ub⊗⇩uc| a b c. True}›])
have ‹separating TYPE('d) {b ⊗⇩u c |b c. True}›
apply (rule separating_tensor'[where A=UNIV and B=UNIV])
by auto
then show ‹separating TYPE('d) {a ⊗⇩u b ⊗⇩u c |a b c. True}›
apply (rule_tac separating_tensor'[where A=UNIV and B=‹{b⊗⇩uc| b c. True}›])
by auto
show ‹clinear F› ‹clinear G› by auto
show ‹x ∈ {a ⊗⇩u b ⊗⇩u c |a b c. True} ⟹ F x = G x› for x
using assms(3) by auto
qed
lemma tensor_extensionality3':
fixes F G :: ‹(('a::finite×'b::finite)×'c::finite) update ⇒ 'd::finite update›
assumes [simp]: ‹register F› ‹register G›
assumes "⋀f g h. F ((f ⊗⇩u g) ⊗⇩u h) = G ((f ⊗⇩u g) ⊗⇩u h)"
shows "F = G"
proof (rule register_eqI[where A=‹{(a⊗⇩ub)⊗⇩uc| a b c. True}›])
have ‹separating TYPE('d) {a ⊗⇩u b | a b. True}›
apply (rule separating_tensor'[where A=UNIV and B=UNIV])
by auto
then show ‹separating TYPE('d) {(a ⊗⇩u b) ⊗⇩u c |a b c. True}›
apply (rule_tac separating_tensor'[where B=UNIV and A=‹{a⊗⇩ub| a b. True}›])
by auto
show ‹clinear F› ‹clinear G› by auto
show ‹x ∈ {(a ⊗⇩u b) ⊗⇩u c |a b c. True} ⟹ F x = G x› for x
using assms(3) by auto
qed
lemma register_tensor_id[simp]: ‹id ⊗⇩r id = id›
apply (rule tensor_extensionality)
by (auto simp add: register_tensor_is_register)
subsection ‹Pairs and compatibility›
definition compatible :: ‹('a::finite update ⇒ 'c::finite update)
⇒ ('b::finite update ⇒ 'c update) ⇒ bool› where
‹compatible F G ⟷ register F ∧ register G ∧ (∀a b. F a *⇩u G b = G b *⇩u F a)›
lemma compatibleI:
assumes "register F" and "register G"
assumes ‹⋀a b. (F a) *⇩u (G b) = (G b) *⇩u (F a)›
shows "compatible F G"
using assms unfolding compatible_def by simp
lemma swap_registers:
assumes "compatible R S"
shows "R a *⇩u S b = S b *⇩u R a"
using assms unfolding compatible_def by metis
lemma compatible_sym: "compatible x y ⟹ compatible y x"
by (simp add: compatible_def)
lemma pair_is_register[simp]:
assumes "compatible F G"
shows "register (F; G)"
by (metis assms compatible_def register_pair_is_register)
lemma register_pair_apply:
assumes ‹compatible F G›
shows ‹(F; G) (a ⊗⇩u b) = (F a) *⇩u (G b)›
apply (rule register_pair_apply)
using assms unfolding compatible_def by metis+
lemma register_pair_apply':
assumes ‹compatible F G›
shows ‹(F; G) (a ⊗⇩u b) = (G b) *⇩u (F a)›
apply (subst register_pair_apply)
using assms by (auto simp: compatible_def intro: register_preregister)
lemma compatible_comp_left[simp]: "compatible F G ⟹ register H ⟹ compatible (F ∘ H) G"
by (simp add: compatible_def)
lemma compatible_comp_right[simp]: "compatible F G ⟹ register H ⟹ compatible F (G ∘ H)"
by (simp add: compatible_def)
lemma compatible_comp_inner[simp]:
"compatible F G ⟹ register H ⟹ compatible (H ∘ F) (H ∘ G)"
by (smt (verit, best) comp_apply compatible_def register_comp register_mult)
lemma compatible_register1: ‹compatible F G ⟹ register F›
by (simp add: compatible_def)
lemma compatible_register2: ‹compatible F G ⟹ register G›
by (simp add: compatible_def)
lemma pair_o_tensor:
assumes "compatible A B" and [simp]: ‹register C› and [simp]: ‹register D›
shows "(A; B) o (C ⊗⇩r D) = (A o C; B o D)"
apply (rule tensor_extensionality)
using assms by (simp_all add: register_tensor_is_register register_pair_apply clinear_compose)
lemma compatible_tensor_id_update_left[simp]:
fixes F :: "'a::finite update ⇒ 'c::finite update" and G :: "'b::finite update ⇒ 'c::finite update"
assumes "compatible F G"
shows "compatible (λa. id_cblinfun ⊗⇩u F a) (λa. id_cblinfun ⊗⇩u G a)"
using assms apply (rule compatible_comp_inner[unfolded o_def])
by simp
lemma compatible_tensor_id_update_right[simp]:
fixes F :: "'a::finite update ⇒ 'c::finite update" and G :: "'b::finite update ⇒ 'c::finite update"
assumes "compatible F G"
shows "compatible (λa. F a ⊗⇩u id_cblinfun) (λa. G a ⊗⇩u id_cblinfun)"
using assms apply (rule compatible_comp_inner[unfolded o_def])
by simp
lemma compatible_tensor_id_update_rl[simp]:
assumes "register F" and "register G"
shows "compatible (λa. F a ⊗⇩u id_cblinfun) (λa. id_cblinfun ⊗⇩u G a)"
apply (rule compatibleI)
using assms by (auto simp: comp_tensor_op)
lemma compatible_tensor_id_update_lr[simp]:
assumes "register F" and "register G"
shows "compatible (λa. id_cblinfun ⊗⇩u F a) (λa. G a ⊗⇩u id_cblinfun)"
apply (rule compatibleI)
using assms by (auto simp: comp_tensor_op)
lemma register_comp_pair:
assumes [simp]: ‹register F› and [simp]: ‹compatible G H›
shows "(F o G; F o H) = F o (G; H)"
proof (rule tensor_extensionality)
show ‹clinear (F ∘ G;F ∘ H)› and ‹clinear (F ∘ (G;H))›
by simp_all
have [simp]: ‹compatible (F o G) (F o H)›
apply (rule compatible_comp_inner, simp)
by simp
then have [simp]: ‹register (F ∘ G)› ‹register (F ∘ H)›
unfolding compatible_def by auto
from assms have [simp]: ‹register G› ‹register H›
unfolding compatible_def by auto
fix a b
show ‹(F ∘ G;F ∘ H) (a ⊗⇩u b) = (F ∘ (G;H)) (a ⊗⇩u b)›
by (auto simp: register_pair_apply register_mult comp_tensor_op)
qed
lemma swap_registers_left:
assumes "compatible R S"
shows "R a *⇩u S b *⇩u c = S b *⇩u R a *⇩u c"
using assms unfolding compatible_def by metis
lemma swap_registers_right:
assumes "compatible R S"
shows "c *⇩u R a *⇩u S b = c *⇩u S b *⇩u R a"
by (metis assms cblinfun_compose_assoc compatible_def)
lemmas compatible_ac_rules = swap_registers cblinfun_compose_assoc[symmetric] swap_registers_right
subsection ‹Fst and Snd›
definition Fst where ‹Fst a = a ⊗⇩u id_cblinfun›
definition Snd where ‹Snd a = id_cblinfun ⊗⇩u a›
lemma register_Fst[simp]: ‹register Fst›
unfolding Fst_def by (rule register_tensor_left)
lemma register_Snd[simp]: ‹register Snd›
unfolding Snd_def by (rule register_tensor_right)
lemma compatible_Fst_Snd[simp]: ‹compatible Fst Snd›
apply (rule compatibleI, simp, simp)
by (simp add: Fst_def Snd_def comp_tensor_op)
lemmas compatible_Snd_Fst[simp] = compatible_Fst_Snd[THEN compatible_sym]
definition ‹swap = (Snd; Fst)›
lemma swap_apply[simp]: "swap (a ⊗⇩u b) = (b ⊗⇩u a)"
unfolding swap_def
by (simp add: Axioms_Quantum.register_pair_apply Fst_def Snd_def comp_tensor_op)
lemma swap_o_Fst: "swap o Fst = Snd"
by (auto simp add: Fst_def Snd_def)
lemma swap_o_Snd: "swap o Snd = Fst"
by (auto simp add: Fst_def Snd_def)
lemma register_swap[simp]: ‹register swap›
by (simp add: swap_def)
lemma pair_Fst_Snd: ‹(Fst; Snd) = id›
apply (rule tensor_extensionality)
by (simp_all add: register_pair_apply Fst_def Snd_def comp_tensor_op)
lemma swap_o_swap[simp]: ‹swap o swap = id›
by (metis swap_def compatible_Snd_Fst pair_Fst_Snd register_comp_pair register_swap swap_o_Fst swap_o_Snd)
lemma swap_swap[simp]: ‹swap (swap x) = x›
by (simp add: pointfree_idE)
lemma inv_swap[simp]: ‹inv swap = swap›
by (meson inv_unique_comp swap_o_swap)
lemma register_pair_Fst:
assumes ‹compatible F G›
shows ‹(F;G) o Fst = F›
using assms by (auto intro!: ext simp: Fst_def register_pair_apply compatible_register2)
lemma register_pair_Snd:
assumes ‹compatible F G›
shows ‹(F;G) o Snd = G›
using assms by (auto intro!: ext simp: Snd_def register_pair_apply compatible_register1)
lemma register_Fst_register_Snd[simp]:
assumes ‹register F›
shows ‹(F o Fst; F o Snd) = F›
apply (rule tensor_extensionality)
using assms by (auto simp: register_pair_apply Fst_def Snd_def register_mult comp_tensor_op)
lemma register_Snd_register_Fst[simp]:
assumes ‹register F›
shows ‹(F o Snd; F o Fst) = F o swap›
apply (rule tensor_extensionality)
using assms by (auto simp: register_pair_apply Fst_def Snd_def register_mult comp_tensor_op)
lemma compatible3[simp]:
assumes [simp]: "compatible F G" and "compatible G H" and "compatible F H"
shows "compatible (F; G) H"
proof (rule compatibleI)
have [simp]: ‹register F› ‹register G› ‹register H›
using assms compatible_def by auto
then have [simp]: ‹clinear F› ‹clinear G› ‹clinear H›
using register_preregister by blast+
have [simp]: ‹clinear (λa. (F;G) a *⇩u z)› for z
apply (rule clinear_compose[unfolded o_def, of ‹(F;G)›])
by simp_all
have [simp]: ‹clinear (λa. z *⇩u (F;G) a)› for z
apply (rule clinear_compose[unfolded o_def, of ‹(F;G)›])
by simp_all
have "(F; G) (f ⊗⇩u g) *⇩u H h = H h *⇩u (F; G) (f ⊗⇩u g)" for f g h
proof -
have FH: "F f *⇩u H h = H h *⇩u F f"
using assms compatible_def by metis
have GH: "G g *⇩u H h = H h *⇩u G g"
using assms compatible_def by metis
have ‹(F; G) (f ⊗⇩u g) *⇩u (H h) = F f *⇩u G g *⇩u H h›
using ‹compatible F G› by (subst register_pair_apply, auto)
also have ‹… = H h *⇩u F f *⇩u G g›
using FH GH by (metis cblinfun_compose_assoc)
also have ‹… = H h *⇩u (F; G) (f ⊗⇩u g)›
using ‹compatible F G› by (subst register_pair_apply, auto simp: cblinfun_compose_assoc)
finally show ?thesis
by -
qed
then show "(F; G) fg *⇩u (H h) = (H h) *⇩u (F; G) fg" for fg h
apply (rule_tac tensor_extensionality[THEN fun_cong])
by auto
show "register H" and "register (F; G)"
by simp_all
qed
lemma compatible3'[simp]:
assumes "compatible F G" and "compatible G H" and "compatible F H"
shows "compatible F (G; H)"
apply (rule compatible_sym)
apply (rule compatible3)
using assms by (auto simp: compatible_sym)
lemma pair_o_swap[simp]:
assumes [simp]: "compatible A B"
shows "(A; B) o swap = (B; A)"
proof (rule tensor_extensionality)
have [simp]: "clinear A" "clinear B"
apply (metis (no_types, opaque_lifting) assms compatible_register1 register_preregister)
by (metis (full_types) assms compatible_register2 register_preregister)
then show ‹clinear ((A; B) ∘ swap)›
by simp
show ‹clinear (B; A)›
by (metis (no_types, lifting) assms compatible_sym register_preregister pair_is_register)
show ‹((A; B) ∘ swap) (a ⊗⇩u b) = (B; A) (a ⊗⇩u b)› for a b
apply (simp only: o_def swap_apply)
apply (subst register_pair_apply, simp)
apply (subst register_pair_apply, simp add: compatible_sym)
by (metis (no_types, lifting) assms compatible_def)
qed
subsection ‹Compatibility of register tensor products›
lemma compatible_register_tensor:
fixes F :: ‹'a::finite update ⇒ 'e::finite update› and G :: ‹'b::finite update ⇒ 'f::finite update›
and F' :: ‹'c::finite update ⇒ 'e update› and G' :: ‹'d::finite update ⇒ 'f update›
assumes [simp]: ‹compatible F F'›
assumes [simp]: ‹compatible G G'›
shows ‹compatible (F ⊗⇩r G) (F' ⊗⇩r G')›
proof -
note [intro!] =
clinear_compose[OF _ preregister_mult_right, unfolded o_def]
clinear_compose[OF _ preregister_mult_left, unfolded o_def]
clinear_compose
register_tensor_is_register
have [simp]: ‹register F› ‹register G› ‹register F'› ‹register G'›
using assms compatible_def by blast+
have [simp]: ‹register (F ⊗⇩r G)› ‹register (F' ⊗⇩r G')›
by (auto simp add: register_tensor_def)
have [simp]: ‹register (F;F')› ‹register (G;G')›
by auto
define reorder :: ‹(('a×'b) × ('c×'d)) update ⇒ (('a×'c) × ('b×'d)) update›
where ‹reorder = ((Fst o Fst; Snd o Fst); (Fst o Snd; Snd o Snd))›
have [simp]: ‹clinear reorder›
by (auto simp: reorder_def)
have [simp]: ‹reorder ((a ⊗⇩u b) ⊗⇩u (c ⊗⇩u d)) = ((a ⊗⇩u c) ⊗⇩u (b ⊗⇩u d))› for a b c d
apply (simp add: reorder_def register_pair_apply)
by (simp add: Fst_def Snd_def comp_tensor_op)
define Φ where ‹Φ c d = ((F;F') ⊗⇩r (G;G')) o reorder o (λσ. σ ⊗⇩u (c ⊗⇩u d))› for c d
have [simp]: ‹clinear (Φ c d)› for c d
unfolding Φ_def
by (auto intro: register_preregister)
have ‹Φ c d (a ⊗⇩u b) = (F ⊗⇩r G) (a ⊗⇩u b) *⇩u (F' ⊗⇩r G') (c ⊗⇩u d)› for a b c d
unfolding Φ_def by (auto simp: register_pair_apply comp_tensor_op)
then have Φ1: ‹Φ c d σ = (F ⊗⇩r G) σ *⇩u (F' ⊗⇩r G') (c ⊗⇩u d)› for c d σ
apply (rule_tac fun_cong[of _ _ σ])
apply (rule tensor_extensionality)
by auto
have ‹Φ c d (a ⊗⇩u b) = (F' ⊗⇩r G') (c ⊗⇩u d) *⇩u (F ⊗⇩r G) (a ⊗⇩u b)› for a b c d
unfolding Φ_def apply (auto simp: register_pair_apply)
by (metis assms(1) assms(2) compatible_def comp_tensor_op)
then have Φ2: ‹Φ c d σ = (F' ⊗⇩r G') (c ⊗⇩u d) *⇩u (F ⊗⇩r G) σ› for c d σ
apply (rule_tac fun_cong[of _ _ σ])
apply (rule tensor_extensionality)
by auto
from Φ1 Φ2 have ‹(F ⊗⇩r G) σ *⇩u (F' ⊗⇩r G') τ = (F' ⊗⇩r G') τ *⇩u (F ⊗⇩r G) σ› for τ σ
apply (rule_tac fun_cong[of _ _ τ])
apply (rule tensor_extensionality)
by auto
then show ?thesis
apply (rule compatibleI[rotated -1])
by auto
qed
subsection ‹Associativity of the tensor product›
definition assoc :: ‹(('a::finite×'b::finite)×'c::finite) update ⇒ ('a×('b×'c)) update› where
‹assoc = ((Fst; Snd o Fst); Snd o Snd)›
lemma assoc_is_hom[simp]: ‹clinear assoc›
by (auto simp: assoc_def)
lemma assoc_apply[simp]: ‹assoc ((a ⊗⇩u b) ⊗⇩u c) = (a ⊗⇩u (b ⊗⇩u c))›
by (auto simp: assoc_def register_pair_apply Fst_def Snd_def comp_tensor_op)
definition assoc' :: ‹('a×('b×'c)) update ⇒ (('a::finite×'b::finite)×'c::finite) update› where
‹assoc' = (Fst o Fst; (Fst o Snd; Snd))›
lemma assoc'_is_hom[simp]: ‹clinear assoc'›
by (auto simp: assoc'_def)
lemma assoc'_apply[simp]: ‹assoc' (a ⊗⇩u (b ⊗⇩u c)) = ((a ⊗⇩u b) ⊗⇩u c)›
by (auto simp: assoc'_def register_pair_apply Fst_def Snd_def comp_tensor_op)
lemma register_assoc[simp]: ‹register assoc›
unfolding assoc_def
by force
lemma register_assoc'[simp]: ‹register assoc'›
unfolding assoc'_def
by force
lemma pair_o_assoc[simp]:
assumes [simp]: ‹compatible F G› ‹compatible G H› ‹compatible F H›
shows ‹(F; (G; H)) ∘ assoc = ((F; G); H)›
proof (rule tensor_extensionality3')
show ‹register ((F; (G; H)) ∘ assoc)›
by simp
show ‹register ((F; G); H)›
by simp
show ‹((F; (G; H)) ∘ assoc) ((f ⊗⇩u g) ⊗⇩u h) = ((F; G); H) ((f ⊗⇩u g) ⊗⇩u h)› for f g h
by (simp add: register_pair_apply assoc_apply cblinfun_compose_assoc)
qed
lemma pair_o_assoc'[simp]:
assumes [simp]: ‹compatible F G› ‹compatible G H› ‹compatible F H›
shows ‹((F; G); H) ∘ assoc' = (F; (G; H))›
proof (rule tensor_extensionality3)
show ‹register (((F; G); H) ∘ assoc')›
by simp
show ‹register (F; (G; H))›
by simp
show ‹(((F; G); H) ∘ assoc') (f ⊗⇩u g ⊗⇩u h) = (F; (G; H)) (f ⊗⇩u g ⊗⇩u h)› for f g h
by (simp add: register_pair_apply assoc'_apply cblinfun_compose_assoc)
qed
lemma assoc'_o_assoc[simp]: ‹assoc' o assoc = id›
apply (rule tensor_extensionality3')
by auto
lemma assoc'_assoc[simp]: ‹assoc' (assoc x) = x›
by (simp add: pointfree_idE)
lemma assoc_o_assoc'[simp]: ‹assoc o assoc' = id›
apply (rule tensor_extensionality3)
by auto
lemma assoc_assoc'[simp]: ‹assoc (assoc' x) = x›
by (simp add: pointfree_idE)
lemma inv_assoc[simp]: ‹inv assoc = assoc'›
using assoc'_o_assoc assoc_o_assoc' inv_unique_comp by blast
lemma inv_assoc'[simp]: ‹inv assoc' = assoc›
by (simp add: inv_equality)
lemma [simp]: ‹bij assoc›
using assoc'_o_assoc assoc_o_assoc' o_bij by blast
lemma [simp]: ‹bij assoc'›
using assoc'_o_assoc assoc_o_assoc' o_bij by blast
subsection ‹Iso-registers›
definition ‹iso_register F ⟷ register F ∧ (∃G. register G ∧ F o G = id ∧ G o F = id)›
for F :: ‹_::finite update ⇒ _::finite update›
lemma iso_registerI:
assumes ‹register F› ‹register G› ‹F o G = id› ‹G o F = id›
shows ‹iso_register F›
using assms(1) assms(2) assms(3) assms(4) iso_register_def by blast
lemma iso_register_inv: ‹iso_register F ⟹ iso_register (inv F)›
by (metis inv_unique_comp iso_register_def)
lemma iso_register_inv_comp1: ‹iso_register F ⟹ inv F o F = id›
using inv_unique_comp iso_register_def by blast
lemma iso_register_inv_comp2: ‹iso_register F ⟹ F o inv F = id›
using inv_unique_comp iso_register_def by blast
lemma iso_register_id[simp]: ‹iso_register id›
by (simp add: iso_register_def)
lemma iso_register_is_register: ‹iso_register F ⟹ register F›
using iso_register_def by blast
lemma iso_register_comp[simp]:
assumes [simp]: ‹iso_register F› ‹iso_register G›
shows ‹iso_register (F o G)›
proof -
from assms obtain F' G' where [simp]: ‹register F'› ‹register G'› ‹F o F' = id› ‹F' o F = id›
‹G o G' = id› ‹G' o G = id›
by (meson iso_register_def)
show ?thesis
apply (rule iso_registerI[where G=‹G' o F'›])
apply (auto simp: register_tensor_is_register iso_register_is_register register_tensor_distrib)
apply (metis ‹F ∘ F' = id› ‹G ∘ G' = id› fcomp_assoc fcomp_comp id_fcomp)
by (metis (no_types, lifting) ‹F ∘ F' = id› ‹F' ∘ F = id› ‹G' ∘ G = id› fun.map_comp inj_iff inv_unique_comp o_inv_o_cancel)
qed
lemma iso_register_tensor_is_iso_register[simp]:
assumes [simp]: ‹iso_register F› ‹iso_register G›
shows ‹iso_register (F ⊗⇩r G)›
proof -
from assms obtain F' G' where [simp]: ‹register F'› ‹register G'› ‹F o F' = id› ‹F' o F = id›
‹G o G' = id› ‹G' o G = id›
by (meson iso_register_def)
show ?thesis
apply (rule iso_registerI[where G=‹F' ⊗⇩r G'›])
by (auto simp: register_tensor_is_register iso_register_is_register register_tensor_distrib)
qed
lemma iso_register_bij: ‹iso_register F ⟹ bij F›
using iso_register_def o_bij by auto
lemma inv_register_tensor[simp]:
assumes [simp]: ‹iso_register F› ‹iso_register G›
shows ‹inv (F ⊗⇩r G) = inv F ⊗⇩r inv G›
apply (auto intro!: inj_imp_inv_eq bij_is_inj iso_register_bij
simp: register_tensor_distrib[unfolded o_def, THEN fun_cong] iso_register_is_register
iso_register_inv bij_is_surj iso_register_bij surj_f_inv_f)
by (metis eq_id_iff register_tensor_id)
lemma iso_register_swap[simp]: ‹iso_register swap›
apply (rule iso_registerI[of _ swap])
by auto
lemma iso_register_assoc[simp]: ‹iso_register assoc›
apply (rule iso_registerI[of _ assoc'])
by auto
lemma iso_register_assoc'[simp]: ‹iso_register assoc'›
apply (rule iso_registerI[of _ assoc])
by auto
definition ‹equivalent_registers F G ⟷ (register F ∧ (∃I. iso_register I ∧ F o I = G))›
for F G :: ‹_::finite update ⇒ _::finite update›
lemma iso_register_equivalent_id[simp]: ‹equivalent_registers id F ⟷ iso_register F›
by (simp add: equivalent_registers_def)
lemma equivalent_registersI:
assumes ‹register F›
assumes ‹iso_register I›
assumes ‹F o I = G›
shows ‹equivalent_registers F G›
using assms unfolding equivalent_registers_def by blast
lemma equivalent_registers_register_left: ‹equivalent_registers F G ⟹ register F›
using equivalent_registers_def by auto
lemma equivalent_registers_register_right: ‹register G› if ‹equivalent_registers F G›
by (metis equivalent_registers_def iso_register_def register_comp that)
lemma equivalent_registers_sym:
assumes ‹equivalent_registers F G›
shows ‹equivalent_registers G F›
by (smt (verit) assms comp_id equivalent_registers_def equivalent_registers_register_right fun.map_comp iso_register_def)
lemma equivalent_registers_trans[trans]:
assumes ‹equivalent_registers F G› and ‹equivalent_registers G H›
shows ‹equivalent_registers F H›
proof -
from assms have [simp]: ‹register F› ‹register G›
by (auto simp: equivalent_registers_def)
from assms(1) obtain I where [simp]: ‹iso_register I› and ‹F o I = G›
using equivalent_registers_def by blast
from assms(2) obtain J where [simp]: ‹iso_register J› and ‹G o J = H›
using equivalent_registers_def by blast
have ‹register F›
by (auto simp: equivalent_registers_def)
moreover have ‹iso_register (I o J)›
using ‹iso_register I› ‹iso_register J› iso_register_comp by blast
moreover have ‹F o (I o J) = H›
by (simp add: ‹F ∘ I = G› ‹G ∘ J = H› o_assoc)
ultimately show ?thesis
by (rule equivalent_registersI)
qed
lemma equivalent_registers_assoc[simp]:
assumes [simp]: ‹compatible F G› ‹compatible F H› ‹compatible G H›
shows ‹equivalent_registers (F;(G;H)) ((F;G);H)›
apply (rule equivalent_registersI[where I=assoc])
by auto
lemma equivalent_registers_pair_right:
assumes [simp]: ‹compatible F G›
assumes eq: ‹equivalent_registers G H›
shows ‹equivalent_registers (F;G) (F;H)›
proof -
from eq obtain I where [simp]: ‹iso_register I› and ‹G o I = H›
by (metis equivalent_registers_def)
then have *: ‹(F;G) ∘ (id ⊗⇩r I) = (F;H)›
by (auto intro!: tensor_extensionality register_comp register_preregister register_tensor_is_register
simp: register_pair_apply iso_register_is_register)
show ?thesis
apply (rule equivalent_registersI[where I=‹id ⊗⇩r I›])
using * by (auto intro!: iso_register_tensor_is_iso_register)
qed
lemma equivalent_registers_pair_left:
assumes [simp]: ‹compatible F G›
assumes eq: ‹equivalent_registers F H›
shows ‹equivalent_registers (F;G) (H;G)›
proof -
from eq obtain I where [simp]: ‹iso_register I› and ‹F o I = H›
by (metis equivalent_registers_def)
then have *: ‹(F;G) ∘ (I ⊗⇩r id) = (H;G)›
by (auto intro!: tensor_extensionality register_comp register_preregister register_tensor_is_register
simp: register_pair_apply iso_register_is_register)
show ?thesis
apply (rule equivalent_registersI[where I=‹I ⊗⇩r id›])
using * by (auto intro!: iso_register_tensor_is_iso_register)
qed
lemma equivalent_registers_comp:
assumes ‹register H›
assumes ‹equivalent_registers F G›
shows ‹equivalent_registers (H o F) (H o G)›
by (metis (no_types, lifting) assms(1) assms(2) comp_assoc equivalent_registers_def register_comp)
subsection ‹Compatibility simplification›
text ‹The simproc ‹compatibility_warn› produces helpful warnings for subgoals of the form
\<^term>‹compatible x y› that are probably unsolvable due to missing declarations of
variable compatibility facts. Same for subgoals of the form \<^term>‹register x›.›
simproc_setup "compatibility_warn" ("compatible x y" | "register x") = ‹
let val thy_string = Markup.markup (Theory.get_markup \<^theory>) (Context.theory_name \<^theory>)
in
fn m => fn ctxt => fn ct => let
val (x,y) = case Thm.term_of ct of
Const(\<^const_name>‹compatible›,_ ) $ x $ y => (x, SOME y)
| Const(\<^const_name>‹register›,_ ) $ x => (x, NONE)
val str : string lazy = Lazy.lazy (fn () => Syntax.string_of_term ctxt (Thm.term_of ct))
fun w msg = warning (msg ^ "\n(Disable these warnings with: using [[simproc del: "^thy_string^".compatibility_warn]])")
val _ = case (x,y) of
(Free(n,T), SOME (Free(n',T'))) =>
if String.isPrefix ":" n orelse String.isPrefix ":" n' then
w ("Simplification subgoal " ^ Lazy.force str ^ " contains a bound variable.\n" ^
"Try to add some assumptions that makes this goal solvable by the simplifier")
else if n=n' then (if T=T' then ()
else w ("In simplification subgoal " ^ Lazy.force str ^
", variables have same name and different types.\n" ^
"Probably something is wrong."))
else w ("Simplification subgoal " ^ Lazy.force str ^
" occurred but cannot be solved.\n" ^
"Please add assumption/fact [simp]: ‹" ^ Lazy.force str ^
"› somewhere.")
| (Free(n,T), NONE) =>
if String.isPrefix ":" n then
w ("Simplification subgoal '" ^ Lazy.force str ^ "' contains a bound variable.\n" ^
"Try to add some assumptions that makes this goal solvable by the simplifier")
else w ("Simplification subgoal " ^ Lazy.force str ^ " occurred but cannot be solved.\n" ^
"Please add assumption/fact [simp]: ‹" ^ Lazy.force str ^ "› somewhere.")
| _ => ()
in NONE end
end›
named_theorems register_attribute_rule_immediate
named_theorems register_attribute_rule
lemmas [register_attribute_rule] = conjunct1 conjunct2 iso_register_is_register iso_register_is_register[OF iso_register_inv]
lemmas [register_attribute_rule_immediate] = compatible_sym compatible_register1 compatible_register2
asm_rl[of ‹compatible _ _›] asm_rl[of ‹iso_register _›] asm_rl[of ‹register _›] iso_register_inv
text ‹The following declares an attribute ‹[register]›. When the attribute is applied to a fact
of the form \<^term>‹register F›, \<^term>‹iso_register F›, \<^term>‹compatible F G› or a conjunction of these,
then those facts are added to the simplifier together with some derived theorems
(e.g., \<^term>‹compatible F G› also adds \<^term>‹register F›).
In theory ‹Laws_Complement›, support for \<^term>‹is_unit_register F› and \<^term>‹complements F G› is
added to this attribute.›
setup ‹
let
fun add thm results =
Net.insert_term (K true) (Thm.concl_of thm, thm) results
handle Net.INSERT => results
fun try_rule f thm rule state = case SOME (rule OF [thm]) handle THM _ => NONE of
NONE => state | SOME th => f th state
fun collect (rules,rules_immediate) thm results =
results |> fold (try_rule add thm) rules_immediate |> fold (try_rule (collect (rules,rules_immediate)) thm) rules
fun declare thm context = let
val ctxt = Context.proof_of context
val rules = Named_Theorems.get ctxt @{named_theorems register_attribute_rule}
val rules_immediate = Named_Theorems.get ctxt @{named_theorems register_attribute_rule_immediate}
val thms = collect (rules,rules_immediate) thm Net.empty |> Net.entries
in Simplifier.map_ss (fn ctxt => ctxt addsimps thms) context end
in
Attrib.setup \<^binding>‹register›
(Scan.succeed (Thm.declaration_attribute declare))
"Add register-related rules to the simplifier"
end
›
subsection ‹Notation›
no_notation cblinfun_compose (infixl "*⇩u" 55)
no_notation tensor_op (infixr "⊗⇩u" 70)
bundle register_notation begin
notation register_tensor (infixr "⊗⇩r" 70)
notation register_pair ("'(_;_')")
end
bundle no_register_notation begin
no_notation register_tensor (infixr "⊗⇩r" 70)
no_notation register_pair ("'(_;_')")
end
end
Theory Quantum
section ‹Quantum mechanics basics›
theory Quantum
imports
Finite_Tensor_Product
"HOL-Library.Z2"
Jordan_Normal_Form.Matrix_Impl
Real_Impl.Real_Impl
"HOL-Library.Code_Target_Numeral"
begin
type_synonym ('a,'b) matrix = ‹('a ell2, 'b ell2) cblinfun›
subsection ‹Basic quantum states›
subsubsection ‹EPR pair›
definition "vector_β00 = vec_of_list [ 1/sqrt 2::complex, 0, 0, 1/sqrt 2 ]"
definition β00 :: ‹(bit×bit) ell2› where [code del]: "β00 = basis_enum_of_vec vector_β00"
lemma vec_of_basis_enum_β00[simp]: "vec_of_basis_enum β00 = vector_β00"
by (auto simp add: β00_def vector_β00_def)
lemma vec_of_ell2_β00[simp, code]: "vec_of_ell2 β00 = vector_β00"
by (simp add: vec_of_ell2_def)
lemma norm_β00[simp]: "norm β00 = 1"
by eval
subsubsection ‹Ket plus›
definition "vector_ketplus = vec_of_list [ 1/sqrt 2::complex, 1/sqrt 2 ]"
definition ketplus :: ‹bit ell2› ("|+⟩") where [code del]: ‹ketplus = basis_enum_of_vec vector_ketplus›
lemma vec_of_basis_enum_ketplus[simp]: "vec_of_basis_enum ketplus = vector_ketplus"
by (auto simp add: ketplus_def vector_ketplus_def)
lemma vec_of_ell2_ketplus[simp, code]: "vec_of_ell2 ketplus = vector_ketplus"
by (simp add: vec_of_ell2_def)
subsection ‹Basic quantum gates›
subsubsection ‹Pauli X›
definition "matrix_pauliX = mat_of_rows_list 2 [ [0::complex, 1], [1, 0] ]"
definition pauliX :: ‹(bit, bit) matrix› where [code del]: "pauliX = cblinfun_of_mat matrix_pauliX"
lemma [simp, code]: "mat_of_cblinfun pauliX = matrix_pauliX"
apply (auto simp add: pauliX_def matrix_pauliX_def)
apply (subst cblinfun_of_mat_inverse)
by (auto)
derive (eq) ceq bit
instantiation bit :: ccompare begin
definition "CCOMPARE(bit) = Some (λb1 b2. case (b1, b2) of (0, 0) ⇒ order.Eq | (0, 1) ⇒ order.Lt | (1, 0) ⇒ order.Gt | (1, 1) ⇒ order.Eq)"
instance
by intro_classes(unfold_locales; auto simp add: ccompare_bit_def split!: bit.splits)
end
derive (dlist) set_impl bit
lemma pauliX_adjoint[simp]: "pauliX* = pauliX"
by eval
lemma pauliXX[simp]: "pauliX o⇩C⇩L pauliX = id_cblinfun"
by eval
subsubsection ‹Pauli Z›
definition "matrix_pauliZ = mat_of_rows_list 2 [ [1::complex, 0], [0, -1] ]"
definition pauliZ :: ‹(bit, bit) matrix› where [code del]: "pauliZ = cblinfun_of_mat matrix_pauliZ"
lemma [simp, code]: "mat_of_cblinfun pauliZ = matrix_pauliZ"
apply (auto simp add: pauliZ_def matrix_pauliZ_def)
apply (subst cblinfun_of_mat_inverse)
by (auto)
lemma pauliZ_adjoint[simp]: "pauliZ* = pauliZ"
by eval
lemma pauliZZ[simp]: "pauliZ o⇩C⇩L pauliZ = id_cblinfun"
by eval
subsubsection Hadamard
definition "matrix_hadamard = mat_of_rows_list 2 [ [1/sqrt 2::complex, 1/sqrt 2], [1/sqrt 2, -1/sqrt 2] ]"
definition hadamard :: ‹(bit,bit) matrix› where [code del]: "hadamard = cblinfun_of_mat matrix_hadamard"
lemma [simp, code]: "mat_of_cblinfun hadamard = matrix_hadamard"
apply (auto simp add: hadamard_def matrix_hadamard_def)
apply (subst cblinfun_of_mat_inverse)
by (auto)
lemma hada_adj[simp]: "hadamard* = hadamard"
by eval
subsubsection CNOT
definition "matrix_CNOT = mat_of_rows_list 4 [ [1::complex,0,0,0], [0,1,0,0], [0,0,0,1], [0,0,1,0] ]"
definition CNOT :: ‹(bit*bit, bit*bit) matrix› where [code del]: "CNOT = cblinfun_of_mat matrix_CNOT"
lemma [simp, code]: "mat_of_cblinfun CNOT = matrix_CNOT"
apply (auto simp add: CNOT_def matrix_CNOT_def)
apply (subst cblinfun_of_mat_inverse)
by (auto)
lemma [simp]: "CNOT* = CNOT"
by eval
lemma cnot_apply[simp]: ‹CNOT *⇩V ket (i,j) = ket (i,j+i)›
apply (rule spec[where x=i], rule spec[where x=j])
by eval
subsubsection ‹Qubit swap›
definition "matrix_Uswap = mat_of_rows_list 4 [ [1::complex, 0, 0, 0], [0,0,1,0], [0,1,0,0], [0,0,0,1] ]"
definition Uswap :: ‹(bit×bit, bit×bit) matrix› where
[code del]: ‹Uswap = cblinfun_of_mat matrix_Uswap›
lemma mat_of_cblinfun_Uswap[simp, code]: "mat_of_cblinfun Uswap = matrix_Uswap"
apply (auto simp add: Uswap_def matrix_Uswap_def)
apply (subst cblinfun_of_mat_inverse)
by (auto)
lemma dim_col_Uswap[simp]: "dim_col matrix_Uswap = 4"
unfolding matrix_Uswap_def by simp
lemma dim_row_Uswap[simp]: "dim_row matrix_Uswap = 4"
unfolding matrix_Uswap_def by simp
lemma Uswap_adjoint[simp]: "Uswap* = Uswap"
by eval
lemma Uswap_involution[simp]: "Uswap o⇩C⇩L Uswap = id_cblinfun"
by eval
lemma unitary_Uswap[simp]: "unitary Uswap"
unfolding unitary_def by simp
lemma Uswap_apply[simp]: ‹Uswap *⇩V s ⊗⇩s t = t ⊗⇩s s›
apply (rule clinear_equal_ket[where f=‹λs. Uswap *⇩V s ⊗⇩s t›, THEN fun_cong])
apply (simp add: cblinfun.add_right clinearI tensor_ell2_add1 tensor_ell2_scaleC1)
apply (simp add: clinear_tensor_ell21)
apply (rule clinear_equal_ket[where f=‹λt. Uswap *⇩V _ ⊗⇩s t›, THEN fun_cong])
apply (simp add: cblinfun.add_right clinearI tensor_ell2_add2 tensor_ell2_scaleC2)
apply (simp add: clinear_tensor_ell22)
apply (rule basis_enum_eq_vec_of_basis_enumI)
apply (simp add: mat_of_cblinfun_cblinfun_apply vec_of_basis_enum_ket)
by (case_tac i; case_tac ia; hypsubst_thin; normalization)
end
Theory Finite_Tensor_Product_Matrices
section ‹Tensor products as matrices›
theory Finite_Tensor_Product_Matrices
imports Finite_Tensor_Product
begin
definition tensor_pack :: "nat ⇒ nat ⇒ (nat × nat) ⇒ nat"
where "tensor_pack X Y = (λ(x, y). x * Y + y)"
definition tensor_unpack :: "nat ⇒ nat ⇒ nat ⇒ (nat × nat)"
where "tensor_unpack X Y xy = (xy div Y, xy mod Y)"
lemma tensor_unpack_inj:
assumes "i < A * B" and "j < A * B"
shows "tensor_unpack A B i = tensor_unpack A B j ⟷ i = j"
by (metis div_mult_mod_eq prod.sel(1) prod.sel(2) tensor_unpack_def)
lemma tensor_unpack_bound1[simp]: "i < A * B ⟹ fst (tensor_unpack A B i) < A"
unfolding tensor_unpack_def
apply auto
using less_mult_imp_div_less by blast
lemma tensor_unpack_bound2[simp]: "i < A * B ⟹ snd (tensor_unpack A B i) < B"
unfolding tensor_unpack_def
apply auto
by (metis mod_less_divisor mult.commute mult_zero_left nat_neq_iff not_less0)
lemma tensor_unpack_fstfst: ‹fst (tensor_unpack A B (fst (tensor_unpack (A * B) C i)))
= fst (tensor_unpack A (B * C) i)›
unfolding tensor_unpack_def apply auto
by (metis div_mult2_eq mult.commute)
lemma tensor_unpack_sndsnd: ‹snd (tensor_unpack B C (snd (tensor_unpack A (B * C) i)))
= snd (tensor_unpack (A * B) C i)›
unfolding tensor_unpack_def apply auto
by (meson dvd_triv_right mod_mod_cancel)
lemma tensor_unpack_fstsnd: ‹fst (tensor_unpack B C (snd (tensor_unpack A (B * C) i)))
= snd (tensor_unpack A B (fst (tensor_unpack (A * B) C i)))›
unfolding tensor_unpack_def apply auto
by (metis (no_types, lifting) Euclidean_Division.div_eq_0_iff add_0_iff bits_mod_div_trivial div_mult_self4 mod_mult2_eq mod_mult_self1_is_0 mult.commute)
definition "tensor_state_jnf ψ φ = (let d1 = dim_vec ψ in let d2 = dim_vec φ in
vec (d1*d2) (λi. let (i1,i2) = tensor_unpack d1 d2 i in (vec_index ψ i1) * (vec_index φ i2)))"
lemma tensor_state_jnf_dim[simp]: ‹dim_vec (tensor_state_jnf ψ φ) = dim_vec ψ * dim_vec φ›
unfolding tensor_state_jnf_def Let_def by simp
lemma enum_prod_nth_tensor_unpack:
assumes ‹i < CARD('a) * CARD('b)›
shows "(Enum.enum ! i :: 'a::enum×'b::enum) =
(let (i1,i2) = tensor_unpack CARD('a) CARD('b) i in
(Enum.enum ! i1, Enum.enum ! i2))"
using assms
by (simp add: enum_prod_def card_UNIV_length_enum product_nth tensor_unpack_def)
lemma vec_of_basis_enum_tensor_state_index:
fixes ψ :: ‹'a::enum ell2› and φ :: ‹'b::enum ell2›
assumes [simp]: ‹i < CARD('a) * CARD('b)›
shows ‹vec_of_basis_enum (ψ ⊗⇩s φ) $ i = (let (i1,i2) = tensor_unpack CARD('a) CARD('b) i in
vec_of_basis_enum ψ $ i1 * vec_of_basis_enum φ $ i2)›
proof -
define i1 i2 where "i1 = fst (tensor_unpack CARD('a) CARD('b) i)"
and "i2 = snd (tensor_unpack CARD('a) CARD('b) i)"
have [simp]: "i1 < CARD('a)" "i2 < CARD('b)"
using assms i1_def tensor_unpack_bound1 apply presburger
using assms i2_def tensor_unpack_bound2 by presburger
have ‹vec_of_basis_enum (ψ ⊗⇩s φ) $ i = Rep_ell2 (ψ ⊗⇩s φ) (enum_class.enum ! i)›
by (simp add: vec_of_basis_enum_ell2_component)
also have ‹… = Rep_ell2 ψ (Enum.enum!i1) * Rep_ell2 φ (Enum.enum!i2)›
apply (transfer fixing: i i1 i2)
by (simp add: enum_prod_nth_tensor_unpack case_prod_beta i1_def i2_def)
also have ‹… = vec_of_basis_enum ψ $ i1 * vec_of_basis_enum φ $ i2›
by (simp add: vec_of_basis_enum_ell2_component)
finally show ?thesis
by (simp add: case_prod_beta i1_def i2_def)
qed
lemma vec_of_basis_enum_tensor_state:
fixes ψ :: ‹'a::enum ell2› and φ :: ‹'b::enum ell2›
shows ‹vec_of_basis_enum (ψ ⊗⇩s φ) = tensor_state_jnf (vec_of_basis_enum ψ) (vec_of_basis_enum φ)›
apply (rule eq_vecI, simp_all)
apply (subst vec_of_basis_enum_tensor_state_index, simp_all)
by (simp add: tensor_state_jnf_def case_prod_beta Let_def)
lemma mat_of_cblinfun_tensor_op_index:
fixes a :: ‹'a::enum ell2 ⇒⇩C⇩L 'b::enum ell2› and b :: ‹'c::enum ell2 ⇒⇩C⇩L 'd::enum ell2›
assumes [simp]: ‹i < CARD('b) * CARD('d)›
assumes [simp]: ‹j < CARD('a) * CARD('c)›
shows ‹mat_of_cblinfun (tensor_op a b) $$ (i,j) =
(let (i1,i2) = tensor_unpack CARD('b) CARD('d) i in
let (j1,j2) = tensor_unpack CARD('a) CARD('c) j in
mat_of_cblinfun a $$ (i1,j1) * mat_of_cblinfun b $$ (i2,j2))›
proof -
define i1 i2 j1 j2
where "i1 = fst (tensor_unpack CARD('b) CARD('d) i)"
and "i2 = snd (tensor_unpack CARD('b) CARD('d) i)"
and "j1 = fst (tensor_unpack CARD('a) CARD('c) j)"
and "j2 = snd (tensor_unpack CARD('a) CARD('c) j)"
have [simp]: "i1 < CARD('b)" "i2 < CARD('d)" "j1 < CARD('a)" "j2 < CARD('c)"
using assms i1_def tensor_unpack_bound1 apply presburger
using assms i2_def tensor_unpack_bound2 apply blast
using assms(2) j1_def tensor_unpack_bound1 apply blast
using assms(2) j2_def tensor_unpack_bound2 by presburger
have ‹mat_of_cblinfun (tensor_op a b) $$ (i,j)
= Rep_ell2 (tensor_op a b *⇩V ket (Enum.enum!j)) (Enum.enum ! i)›
by (simp add: mat_of_cblinfun_ell2_component)
also have ‹… = Rep_ell2 ((a *⇩V ket (Enum.enum!j1)) ⊗⇩s (b *⇩V ket (Enum.enum!j2))) (Enum.enum!i)›
by (simp add: tensor_op_ell2 enum_prod_nth_tensor_unpack[where i=j] Let_def case_prod_beta j1_def[symmetric] j2_def[symmetric] flip: tensor_ell2_ket)
also have ‹… = vec_of_basis_enum ((a *⇩V ket (Enum.enum!j1)) ⊗⇩s b *⇩V ket (Enum.enum!j2)) $ i›
by (simp add: vec_of_basis_enum_ell2_component)
also have ‹… = vec_of_basis_enum (a *⇩V ket (enum_class.enum ! j1)) $ i1 *
vec_of_basis_enum (b *⇩V ket (enum_class.enum ! j2)) $ i2›
by (simp add: case_prod_beta vec_of_basis_enum_tensor_state_index i1_def[symmetric] i2_def[symmetric])
also have ‹… = Rep_ell2 (a *⇩V ket (enum_class.enum ! j1)) (enum_class.enum ! i1) *
Rep_ell2 (b *⇩V ket (enum_class.enum ! j2)) (enum_class.enum ! i2)›
by (simp add: vec_of_basis_enum_ell2_component)
also have ‹… = mat_of_cblinfun a $$ (i1, j1) * mat_of_cblinfun b $$ (i2, j2)›
by (simp add: mat_of_cblinfun_ell2_component)
finally show ?thesis
by (simp add: i1_def[symmetric] i2_def[symmetric] j1_def[symmetric] j2_def[symmetric] case_prod_beta)
qed
definition "tensor_op_jnf A B =
(let r1 = dim_row A in
let c1 = dim_col A in
let r2 = dim_row B in
let c2 = dim_col B in
mat (r1*r2) (c1*c2)
(λ(i,j). let (i1,i2) = tensor_unpack r1 r2 i in
let (j1,j2) = tensor_unpack c1 c2 j in
(A $$ (i1,j1)) * (B $$ (i2,j2))))"
lemma tensor_op_jnf_dim[simp]:
‹dim_row (tensor_op_jnf a b) = dim_row a * dim_row b›
‹dim_col (tensor_op_jnf a b) = dim_col a * dim_col b›
unfolding tensor_op_jnf_def Let_def by simp_all
lemma mat_of_cblinfun_tensor_op:
fixes a :: ‹'a::enum ell2 ⇒⇩C⇩L 'b::enum ell2› and b :: ‹'c::enum ell2 ⇒⇩C⇩L 'd::enum ell2›
shows ‹mat_of_cblinfun (tensor_op a b) = tensor_op_jnf (mat_of_cblinfun a) (mat_of_cblinfun b)›
apply (rule eq_matI, simp_all add: )
apply (subst mat_of_cblinfun_tensor_op_index, simp_all)
by (simp add: tensor_op_jnf_def case_prod_beta Let_def)
lemma mat_of_cblinfun_assoc_ell2'[simp]:
‹mat_of_cblinfun (assoc_ell2' :: (('a::enum×('b::enum×'c::enum)) ell2 ⇒⇩C⇩L _)) = one_mat (CARD('a)*CARD('b)*CARD('c))›
(is "mat_of_cblinfun ?assoc = _")
proof (rule mat_eq_iff[THEN iffD2], intro conjI allI impI)
show ‹dim_row (mat_of_cblinfun ?assoc) =
dim_row (1⇩m (CARD('a) * CARD('b) * CARD('c)))›
by (simp)
show ‹dim_col (mat_of_cblinfun ?assoc) =
dim_col (1⇩m (CARD('a) * CARD('b) * CARD('c)))›
by (simp)
fix i j
let ?i = "Enum.enum ! i :: (('a×'b)×'c)" and ?j = "Enum.enum ! j :: ('a×('b×'c))"
assume ‹i < dim_row (1⇩m (CARD('a) * CARD('b) * CARD('c)))›
then have iB[simp]: ‹i < CARD('a) * CARD('b) * CARD('c)› by simp
then have iB'[simp]: ‹i < CARD('a) * (CARD('b) * CARD('c))› by linarith
assume ‹j < dim_col (1⇩m (CARD('a) * CARD('b) * CARD('c)))›
then have jB[simp]: ‹j < CARD('a) * CARD('b) * CARD('c)› by simp
then have jB'[simp]: ‹j < CARD('a) * (CARD('b) * CARD('c))› by linarith
define i1 i23 i2 i3
where "i1 = fst (tensor_unpack CARD('a) (CARD('b)*CARD('c)) i)"
and "i23 = snd (tensor_unpack CARD('a) (CARD('b)*CARD('c)) i)"
and "i2 = fst (tensor_unpack CARD('b) CARD('c) i23)"
and "i3 = snd (tensor_unpack CARD('b) CARD('c) i23)"
define j12 j1 j2 j3
where "j12 = fst (tensor_unpack (CARD('a)*CARD('b)) CARD('c) j)"
and "j1 = fst (tensor_unpack CARD('a) CARD('b) j12)"
and "j2 = snd (tensor_unpack CARD('a) CARD('b) j12)"
and "j3 = snd (tensor_unpack (CARD('a)*CARD('b)) CARD('c) j)"
have [simp]: "j12 < CARD('a)*CARD('b)" "i23 < CARD('b)*CARD('c)"
using j12_def jB tensor_unpack_bound1 apply presburger
using i23_def iB' tensor_unpack_bound2 by blast
have j1': ‹fst (tensor_unpack CARD('a) (CARD('b) * CARD('c)) j) = j1›
by (simp add: j1_def j12_def tensor_unpack_fstfst)
let ?i1 = "Enum.enum ! i1 :: 'a" and ?i2 = "Enum.enum ! i2 :: 'b" and ?i3 = "Enum.enum ! i3 :: 'c"
let ?j1 = "Enum.enum ! j1 :: 'a" and ?j2 = "Enum.enum ! j2 :: 'b" and ?j3 = "Enum.enum ! j3 :: 'c"
have i: ‹?i = ((?i1,?i2),?i3)›
by (auto simp add: enum_prod_nth_tensor_unpack case_prod_beta
tensor_unpack_fstfst tensor_unpack_fstsnd tensor_unpack_sndsnd i1_def i2_def i23_def i3_def)
have j: ‹?j = (?j1,(?j2,?j3))›
by (auto simp add: enum_prod_nth_tensor_unpack case_prod_beta
tensor_unpack_fstfst tensor_unpack_fstsnd tensor_unpack_sndsnd j1_def j2_def j12_def j3_def)
have ijeq: ‹(?i1,?i2,?i3) = (?j1,?j2,?j3) ⟷ i = j›
unfolding i1_def i2_def i3_def j1_def j2_def j3_def apply simp
apply (subst enum_inj, simp, simp)
apply (subst enum_inj, simp, simp)
apply (subst enum_inj, simp, simp)
apply (subst tensor_unpack_inj[symmetric, where i=i and j=j and A="CARD('a)" and B="CARD('b)*CARD('c)"], simp, simp)
unfolding prod_eq_iff
apply (subst tensor_unpack_inj[symmetric, where i=‹snd (tensor_unpack CARD('a) (CARD('b) * CARD('c)) i)› and A="CARD('b)" and B="CARD('c)"], simp, simp)
by (simp add: i1_def[symmetric] j1_def[symmetric] i2_def[symmetric] j2_def[symmetric] i3_def[symmetric] j3_def[symmetric]
i23_def[symmetric] j12_def[symmetric] j1'
prod_eq_iff tensor_unpack_fstsnd tensor_unpack_sndsnd)
have ‹mat_of_cblinfun ?assoc $$ (i, j) = Rep_ell2 (assoc_ell2' *⇩V ket ?j) ?i›
by (subst mat_of_cblinfun_ell2_component, auto)
also have ‹… = Rep_ell2 ((ket ?j1 ⊗⇩s ket ?j2) ⊗⇩s ket ?j3) ?i›
by (simp add: j assoc_ell2'_tensor flip: tensor_ell2_ket)
also have ‹… = (if (?i1,?i2,?i3) = (?j1,?j2,?j3) then 1 else 0)›
by (auto simp add: ket.rep_eq i)
also have ‹… = (if i=j then 1 else 0)›
using ijeq by simp
finally
show ‹mat_of_cblinfun ?assoc $$ (i, j) =
1⇩m (CARD('a) * CARD('b) * CARD('c)) $$ (i, j)›
by auto
qed
lemma assoc_ell2'_inv: "assoc_ell2 o⇩C⇩L assoc_ell2' = id_cblinfun"
apply (rule equal_ket, case_tac x, hypsubst)
by (simp flip: tensor_ell2_ket add: cblinfun_apply_cblinfun_compose assoc_ell2'_tensor assoc_ell2_tensor)
lemma assoc_ell2_inv: "assoc_ell2' o⇩C⇩L assoc_ell2 = id_cblinfun"
apply (rule equal_ket, case_tac x, hypsubst)
by (simp flip: tensor_ell2_ket add: cblinfun_apply_cblinfun_compose assoc_ell2'_tensor assoc_ell2_tensor)
lemma mat_of_cblinfun_assoc_ell2[simp]:
‹mat_of_cblinfun (assoc_ell2 :: ((('a::enum×'b::enum)×'c::enum) ell2 ⇒⇩C⇩L _)) = one_mat (CARD('a)*CARD('b)*CARD('c))›
(is "mat_of_cblinfun ?assoc = _")
proof -
let ?assoc' = "assoc_ell2' :: (('a::enum×('b::enum×'c::enum)) ell2 ⇒⇩C⇩L _)"
have "one_mat (CARD('a)*CARD('b)*CARD('c)) = mat_of_cblinfun (?assoc o⇩C⇩L ?assoc')"
by (simp add: mult.assoc mat_of_cblinfun_id)
also have ‹… = mat_of_cblinfun ?assoc * mat_of_cblinfun ?assoc'›
using mat_of_cblinfun_compose by blast
also have ‹… = mat_of_cblinfun ?assoc * one_mat (CARD('a)*CARD('b)*CARD('c))›
by simp
also have ‹… = mat_of_cblinfun ?assoc›
apply (rule right_mult_one_mat')
by (simp)
finally show ?thesis
by simp
qed
end
Theory Teleport
section ‹Quantum teleportation›
theory Teleport
imports
QHoare
Real_Impl.Real_Impl
"HOL-Library.Code_Target_Numeral"
Finite_Tensor_Product_Matrices
"HOL-Library.Word"
begin
hide_const (open) Finite_Cartesian_Product.vec
hide_type (open) Finite_Cartesian_Product.vec
hide_const (open) Finite_Cartesian_Product.mat
hide_const (open) Finite_Cartesian_Product.row
hide_const (open) Finite_Cartesian_Product.column
no_notation Group.mult (infixl "⊗ı" 70)
no_notation Order.top ("⊤ı")
unbundle no_vec_syntax
unbundle no_inner_syntax
locale teleport_locale = qhoare "TYPE('mem::finite)" +
fixes X :: "bit update ⇒ 'mem::finite update"
and Φ :: "(bit*bit) update ⇒ 'mem update"
and A :: "'atype::finite update ⇒ 'mem update"
and B :: "'btype::finite update ⇒ 'mem update"
assumes compat[register]: "mutually compatible (X,Φ,A,B)"
begin
abbreviation "Φ1 ≡ Φ ∘ Fst"
abbreviation "Φ2 ≡ Φ ∘ Snd"
abbreviation "XΦ2 ≡ (X;Φ2)"
abbreviation "XΦ1 ≡ (X;Φ1)"
abbreviation "XΦ ≡ (X;Φ)"
abbreviation "XAB ≡ ((X;A); B)"
abbreviation "AB ≡ (A;B)"
abbreviation "Φ2AB ≡ ((Φ o Snd; A); B)"
definition "teleport a b = [
apply CNOT XΦ1,
apply hadamard X,
ifthen Φ1 a,
ifthen X b,
apply (if a=1 then pauliX else id_cblinfun) Φ2,
apply (if b=1 then pauliZ else id_cblinfun) Φ2
]"
lemma Φ_XΦ: ‹Φ a = XΦ (id_cblinfun ⊗⇩o a)›
by (auto simp: register_pair_apply)
lemma XΦ1_XΦ: ‹XΦ1 a = XΦ (assoc (a ⊗⇩o id_cblinfun))›
apply (subst pair_o_assoc[unfolded o_def, of X Φ1 Φ2, simplified, THEN fun_cong])
by (auto simp: register_pair_apply)
lemma XΦ2_XΦ: ‹XΦ2 a = XΦ ((id ⊗⇩r swap) (assoc (a ⊗⇩o id_cblinfun)))›
apply (subst pair_o_tensor[unfolded o_def, THEN fun_cong], simp, simp, simp)
apply (subst (2) register_Fst_register_Snd[symmetric, of Φ], simp)
using [[simproc del: compatibility_warn]]
apply (subst pair_o_swap[unfolded o_def], simp)
apply (subst pair_o_assoc[unfolded o_def, THEN fun_cong], simp, simp, simp)
by (auto simp: register_pair_apply)
lemma Φ2_XΦ: ‹Φ2 a = XΦ (id_cblinfun ⊗⇩o (id_cblinfun ⊗⇩o a))›
by (auto simp: Snd_def register_pair_apply)
lemma X_XΦ: ‹X a = XΦ (a ⊗⇩o id_cblinfun)›
by (auto simp: register_pair_apply)
lemma Φ1_XΦ: ‹Φ1 a = XΦ (id_cblinfun ⊗⇩o (a ⊗⇩o id_cblinfun))›
by (auto simp: Fst_def register_pair_apply)
lemmas to_XΦ = Φ_XΦ XΦ1_XΦ XΦ2_XΦ Φ2_XΦ X_XΦ Φ1_XΦ
lemma X_XΦ1: ‹X a = XΦ1 (a ⊗⇩o id_cblinfun)›
by (auto simp: register_pair_apply)
lemmas to_XΦ1 = X_XΦ1
lemma XAB_to_XΦ2_AB: ‹XAB a = (XΦ2;AB) ((swap ⊗⇩r id) (assoc' (id_cblinfun ⊗⇩o assoc a)))›
by (simp add: pair_o_tensor[unfolded o_def, THEN fun_cong] register_pair_apply
pair_o_swap[unfolded o_def, THEN fun_cong]
pair_o_assoc'[unfolded o_def, THEN fun_cong]
pair_o_assoc[unfolded o_def, THEN fun_cong])
lemma XΦ2_to_XΦ2_AB: ‹XΦ2 a = (XΦ2;AB) (a ⊗⇩o id_cblinfun)›
by (simp add: register_pair_apply)
schematic_goal Φ2AB_to_XΦ2_AB: "Φ2AB a = (XΦ2;AB) ?b"
apply (subst pair_o_assoc'[unfolded o_def, THEN fun_cong])
apply simp_all[3]
apply (subst register_pair_apply[where a=id_cblinfun])
apply simp_all[2]
apply (subst pair_o_assoc[unfolded o_def, THEN fun_cong])
apply simp_all[3]
by simp
lemmas to_XΦ2_AB = XAB_to_XΦ2_AB XΦ2_to_XΦ2_AB Φ2AB_to_XΦ2_AB
lemma teleport:
assumes [simp]: "norm ψ = 1"
shows "hoare (XAB =⇩q ψ ⊓ Φ =⇩q β00) (teleport a b) (Φ2AB =⇩q ψ)"
proof -
define XZ :: ‹bit update› where "XZ = (if a=1 then (if b=1 then pauliZ o⇩C⇩L pauliX else pauliX) else (if b=1 then pauliZ else id_cblinfun))"
define pre where "pre = XAB =⇩q ψ"
define O1 where "O1 = Φ (selfbutter β00)"
have ‹(XAB =⇩q ψ ⊓ Φ =⇩q β00) = O1 *⇩S pre›
unfolding pre_def O1_def EQ_def
apply (subst compatible_proj_intersect[where R=XAB and S=Φ])
apply (simp_all add: butterfly_is_Proj)
apply (subst swap_registers[where R=XAB and S=Φ])
by (simp_all add: cblinfun_assoc_left(2))
also
define O2 where "O2 = XΦ1 CNOT o⇩C⇩L O1"
have ‹hoare (O1 *⇩S pre) [apply CNOT XΦ1] (O2 *⇩S pre)›
apply (rule hoare_apply) by (simp add: O2_def cblinfun_assoc_left(2))
also
define O3 where ‹O3 = X hadamard o⇩C⇩L O2›
have ‹hoare (O2 *⇩S pre) [apply hadamard X] (O3 *⇩S pre)›
apply (rule hoare_apply) by (simp add: O3_def cblinfun_assoc_left(2))
also
define O4 where ‹O4 = Φ1 (selfbutterket a) o⇩C⇩L O3›
have ‹hoare (O3 *⇩S pre) [ifthen Φ1 a] (O4 *⇩S pre)›
apply (rule hoare_ifthen) by (simp add: O4_def cblinfun_assoc_left(2))
also
define O5 where ‹O5 = X (selfbutterket b) o⇩C⇩L O4›
have ‹hoare (O4 *⇩S pre) [ifthen X b] (O5 *⇩S pre)›
apply (rule hoare_ifthen) by (simp add: O5_def cblinfun_assoc_left(2))
also
define O6 where ‹O6 = Φ2 (if a=1 then pauliX else id_cblinfun) o⇩C⇩L O5›
have ‹hoare (O5 *⇩S pre) [apply (if a=1 then pauliX else id_cblinfun) (Φ ∘ Snd)] (O6 *⇩S pre)›
apply (rule hoare_apply) by (auto simp add: O6_def cblinfun_assoc_left(2))
also
define O7 where ‹O7 = Φ2 (if b = 1 then pauliZ else id_cblinfun) o⇩C⇩L O6›
have O7: ‹O7 = Φ2 XZ o⇩C⇩L O5›
by (auto simp add: O6_def O7_def XZ_def register_mult lift_cblinfun_comp[OF register_mult])
have ‹hoare (O6 *⇩S pre) [apply (if b=1 then pauliZ else id_cblinfun) (Φ ∘ Snd)] (O7 *⇩S pre)›
apply (rule hoare_apply)
by (auto simp add: O7_def cblinfun_assoc_left(2))
finally have hoare: ‹hoare (XAB =⇩q ψ ⊓ Φ =⇩q β00) (teleport a b) (O7 *⇩S pre)›
by (auto simp add: teleport_def comp_def)
have O5': "O5 = (1/2) *⇩C Φ2 (XZ*) o⇩C⇩L XΦ2 Uswap o⇩C⇩L Φ (butterfly (ket a ⊗⇩s ket b) β00)"
unfolding O7 O5_def O4_def O3_def O2_def O1_def
apply (simp split del: if_split only: to_XΦ register_mult[of XΦ])
apply (simp split del: if_split add: register_mult[of XΦ]
flip: complex_vector.linear_scale
del: comp_apply)
apply (rule arg_cong[of _ _ XΦ])
apply (rule cblinfun_eq_mat_of_cblinfunI)
apply (simp add: assoc_ell2_sandwich mat_of_cblinfun_tensor_op XZ_def
butterfly_def mat_of_cblinfun_compose mat_of_cblinfun_vector_to_cblinfun
mat_of_cblinfun_adj vec_of_basis_enum_ket mat_of_cblinfun_id
swap_sandwich[abs_def] mat_of_cblinfun_scaleR mat_of_cblinfun_scaleC
id_tensor_sandwich vec_of_basis_enum_tensor_state mat_of_cblinfun_cblinfun_apply
mat_of_cblinfun_sandwich)
by normalization
have [simp]: "unitary XZ"
unfolding unitary_def unfolding XZ_def apply auto
apply (metis cblinfun_assoc_left(1) pauliXX pauliZZ cblinfun_compose_id_left)
by (metis cblinfun_assoc_left(1) pauliXX pauliZZ cblinfun_compose_id_left)
have O7': "O7 = (1/2) *⇩C XΦ2 Uswap o⇩C⇩L Φ (butterfly (ket a ⊗⇩s ket b) β00)"
unfolding O7 O5'
by (simp add: cblinfun_compose_assoc[symmetric] register_mult[of Φ2] del: comp_apply)
have "O7 *⇩S pre = XΦ2 Uswap *⇩S XAB (selfbutter ψ) *⇩S Φ (butterfly (ket (a, b)) β00) *⇩S ⊤"
apply (simp add: O7' pre_def EQ_def cblinfun_compose_image)
apply (subst lift_cblinfun_comp[OF swap_registers[where R=Φ and S=XAB]], simp)
by (simp add: cblinfun_assoc_left(2))
also have ‹… ≤ XΦ2 Uswap *⇩S XAB (selfbutter ψ) *⇩S ⊤›
by (simp add: cblinfun_image_mono)
also have ‹… = (XΦ2;AB) (Uswap ⊗⇩o id_cblinfun) *⇩S (XΦ2;AB)
((swap ⊗⇩r id) (assoc' (id_cblinfun ⊗⇩o assoc (selfbutter ψ)))) *⇩S ⊤›
by (simp add: to_XΦ2_AB)
also have ‹… = Φ2AB (selfbutter ψ) *⇩S XΦ2 Uswap *⇩S ⊤›
apply (simp add: swap_sandwich sandwich_grow_left to_XΦ2_AB
cblinfun_compose_image[symmetric] register_mult)
by (simp add: sandwich_def cblinfun_compose_assoc[symmetric] comp_tensor_op tensor_op_adjoint)
also have ‹… ≤ Φ2AB =⇩q ψ›
by (simp add: EQ_def cblinfun_image_mono)
finally have ‹O7 *⇩S pre ≤ Φ2AB =⇩q ψ›
by simp
with hoare
show ?thesis
by (meson basic_trans_rules(31) hoare_def less_eq_ccsubspace.rep_eq)
qed
end
locale concrete_teleport_vars begin
type_synonym a_state = "64 word"
type_synonym b_state = "1000000 word"
type_synonym mem = "a_state * bit * bit * b_state * bit"
type_synonym 'a var = ‹'a update ⇒ mem update›
definition A :: "a_state var" where ‹A a = a ⊗⇩o id_cblinfun ⊗⇩o id_cblinfun ⊗⇩o id_cblinfun ⊗⇩o id_cblinfun›
definition X :: ‹bit var› where ‹X a = id_cblinfun ⊗⇩o a ⊗⇩o id_cblinfun ⊗⇩o id_cblinfun ⊗⇩o id_cblinfun›
definition Φ1 :: ‹bit var› where ‹Φ1 a = id_cblinfun ⊗⇩o id_cblinfun ⊗⇩o a ⊗⇩o id_cblinfun ⊗⇩o id_cblinfun›
definition B :: ‹b_state var› where ‹B a = id_cblinfun ⊗⇩o id_cblinfun ⊗⇩o id_cblinfun ⊗⇩o a ⊗⇩o id_cblinfun›
definition Φ2 :: ‹bit var› where ‹Φ2 a = id_cblinfun ⊗⇩o id_cblinfun ⊗⇩o id_cblinfun ⊗⇩o id_cblinfun ⊗⇩o a›
end
interpretation teleport_concrete:
concrete_teleport_vars +
teleport_locale concrete_teleport_vars.X
‹(concrete_teleport_vars.Φ1; concrete_teleport_vars.Φ2)›
concrete_teleport_vars.A
concrete_teleport_vars.B
apply standard
using [[simproc del: compatibility_warn]]
by (auto simp: concrete_teleport_vars.X_def[abs_def]
concrete_teleport_vars.Φ1_def[abs_def]
concrete_teleport_vars.Φ2_def[abs_def]
concrete_teleport_vars.A_def[abs_def]
concrete_teleport_vars.B_def[abs_def]
intro!: compatible3' compatible3)
thm teleport
thm teleport_def
end
Theory Axioms_Complement_Quantum
section ‹Quantum instantiation of complements›
theory Axioms_Complement_Quantum
imports Laws_Quantum Finite_Tensor_Product Quantum_Extra
begin
no_notation m_inv ("invı _" [81] 80)
no_notation Lattice.join (infixl "⊔ı" 65)
typedef ('a::finite,'b::finite) complement_domain = ‹{..< if CARD('b) div CARD('a) ≠ 0 then CARD('b) div CARD('a) else 1}›
by auto
instance complement_domain :: (finite, finite) finite
proof intro_classes
have ‹inj Rep_complement_domain›
by (simp add: Rep_complement_domain_inject inj_on_def)
moreover have ‹finite (range Rep_complement_domain)›
by (metis finite_lessThan type_definition.Rep_range type_definition_complement_domain)
ultimately show ‹finite (UNIV :: ('a,'b) complement_domain set)›
using finite_image_iff by blast
qed
lemma CARD_complement_domain:
assumes ‹CARD('b::finite) = n * CARD('a::finite)›
shows ‹CARD(('a,'b) complement_domain) = n›
proof -
from assms have ‹n > 0›
by (metis zero_less_card_finite zero_less_mult_pos2)
have *: ‹inj Rep_complement_domain›
by (simp add: Rep_complement_domain_inject inj_on_def)
moreover have ‹card (range (Rep_complement_domain :: ('a,'b) complement_domain ⇒ _)) = n›
apply (subst type_definition.Rep_range[OF type_definition_complement_domain])
using assms ‹n > 0› by simp
ultimately show ?thesis
by (metis card_image)
qed
lemma register_decomposition:
fixes Φ :: ‹'a::finite update ⇒ 'b::finite update›
assumes [simp]: ‹register Φ›
shows ‹∃U :: ('a × ('a, 'b) complement_domain) ell2 ⇒⇩C⇩L 'b ell2. unitary U ∧
(∀θ. Φ θ = sandwich U (θ ⊗⇩o id_cblinfun))›
proof -
note [[simproc del: compatibility_warn]]
fix ξ0 :: 'a
have [simp]: ‹clinear Φ›
by simp
define P where ‹P i = Proj (ccspan {ket i})› for i :: 'a
have P_butter: ‹P i = selfbutterket i› for i
by (simp add: P_def butterfly_eq_proj)
define P' where ‹P' i = Φ (P i)› for i :: 'a
have proj_P': ‹is_Proj (P' i)› for i
by (simp add: P_def P'_def register_projector)
have ‹(∑i∈UNIV. P i) = id_cblinfun›
using sum_butterfly_ket P_butter by simp
then have sumP'id: ‹(∑i∈UNIV. P' i) = id_cblinfun›
unfolding P'_def
apply (subst complex_vector.linear_sum[OF ‹clinear Φ›, symmetric])
by auto
define S where ‹S i = P' i *⇩S ⊤› for i :: 'a
have P'id: ‹P' i *⇩V ψ = ψ› if ‹ψ ∈ space_as_set (S i)› for i ψ
using S_def that proj_P'
by (metis cblinfun_fixes_range is_Proj_algebraic)
obtain B0 where finiteB0: ‹finite (B0 i)› and cspanB0: ‹cspan (B0 i) = space_as_set (S i)› for i
apply atomize_elim apply (simp flip: all_conj_distrib) apply (rule choice)
by (meson cfinite_dim_finite_subspace_basis csubspace_space_as_set)
obtain B where orthoB: ‹is_ortho_set (B i)›
and normalB: ‹⋀b. b ∈ B i ⟹ norm b = 1›
and cspanB: ‹cspan (B i) = cspan (B0 i)›
and finiteB: ‹finite (B i)› for i
apply atomize_elim apply (simp flip: all_conj_distrib) apply (rule choice)
using orthonormal_basis_of_cspan[OF finiteB0] by blast
from cspanB cspanB0 have cspanB: ‹cspan (B i) = space_as_set (S i)› for i
by simp
then have ccspanB: ‹ccspan (B i) = S i› for i
by (metis ccspan.rep_eq closure_finite_cspan finiteB space_as_set_inject)
from orthoB have indepB: ‹cindependent (B i)› for i
by (simp add: Complex_Inner_Product.is_ortho_set_cindependent)
have orthoBiBj: ‹is_orthogonal x y› if ‹x ∈ B i› and ‹y ∈ B j› and ‹i ≠ j› for x y i j
proof -
from ‹x ∈ B i› obtain x' where x: ‹x = P' i *⇩V x'›
by (metis S_def cblinfun_fixes_range complex_vector.span_base cspanB is_Proj_idempotent proj_P')
from ‹y ∈ B j› obtain y' where y: ‹y = P' j *⇩V y'›
by (metis S_def cblinfun_fixes_range complex_vector.span_base cspanB is_Proj_idempotent proj_P')
have ‹cinner x y = cinner (P' i *⇩V x') (P' j *⇩V y')›
using x y by simp
also have ‹… = cinner (P' j *⇩V P' i *⇩V x') y'›
by (metis cinner_adj_left is_Proj_algebraic proj_P')
also have ‹… = cinner (Φ (P j o⇩C⇩L P i) *⇩V x') y'›
unfolding P'_def register_mult[OF ‹register Φ›, symmetric] by simp
also have ‹… = cinner (Φ (selfbutterket j o⇩C⇩L selfbutterket i) *⇩V x') y'›
unfolding P_butter by simp
also have ‹… = cinner (Φ 0 *⇩V x') y'›
by (metis butterfly_comp_butterfly complex_vector.scale_eq_0_iff orthogonal_ket that(3))
also have ‹… = 0›
by (simp add: complex_vector.linear_0)
finally show ?thesis
by -
qed
define B' where ‹B' = (⋃i∈UNIV. B i)›
have P'B: ‹P' i = Proj (ccspan (B i))› for i
unfolding ccspanB S_def
using proj_P' Proj_on_own_range'[symmetric] is_Proj_algebraic by blast
have ‹(∑i∈UNIV. P' i) = Proj (ccspan B')›
proof (unfold B'_def, use finite[of UNIV] in induction)
case empty
show ?case by auto
next
case (insert j M)
have ‹(∑i∈insert j M. P' i) = P' j + (∑i∈M. P' i)›
by (meson insert.hyps(1) insert.hyps(2) sum.insert)
also have ‹… = Proj (ccspan (B j)) + Proj (ccspan (⋃i∈M. B i))›
unfolding P'B insert.IH[symmetric] by simp
also have ‹… = Proj (ccspan (B j ∪ (⋃i∈M. B i)))›
apply (rule Proj_orthog_ccspan_union[symmetric])
using orthoBiBj insert.hyps(2) by auto
also have ‹… = Proj (ccspan (⋃i∈insert j M. B i))›
by auto
finally show ?case
by simp
qed
with sumP'id
have ccspanB': ‹ccspan B' = ⊤›
by (metis Proj_range cblinfun_image_id)
hence cspanB': ‹cspan B' = UNIV›
by (metis B'_def finiteB ccspan.rep_eq finite_UN_I finite_class.finite_UNIV closure_finite_cspan top_ccsubspace.rep_eq)
from orthoBiBj orthoB have orthoB': ‹is_ortho_set B'›
unfolding B'_def is_ortho_set_def by blast
then have indepB': ‹cindependent B'›
using is_ortho_set_cindependent by blast
have cardB': ‹card B' = CARD('b)›
apply (subst complex_vector.dim_span_eq_card_independent[symmetric])
apply (rule indepB')
apply (subst cspanB')
using cdim_UNIV_ell2 by auto
from orthoBiBj orthoB
have Bdisj: ‹B i ∩ B j = {}› if ‹i ≠ j› for i j
unfolding is_ortho_set_def
apply auto by (metis cinner_eq_zero_iff that)
have cardBsame: ‹card (B i) = card (B j)› for i j
proof -
define Si_to_Sj where ‹Si_to_Sj i j ψ = Φ (butterket j i) *⇩V ψ› for i j ψ
have S2S2S: ‹Si_to_Sj j i (Si_to_Sj i j ψ) = ψ› if ‹ψ ∈ space_as_set (S i)› for i j ψ
using that P'id
by (simp add: Si_to_Sj_def cblinfun_apply_cblinfun_compose[symmetric] register_mult P_butter P'_def)
also have lin[simp]: ‹clinear (Si_to_Sj i j)› for i j
unfolding Si_to_Sj_def by simp
have S2S: ‹Si_to_Sj i j x ∈ space_as_set (S j)› for i j x
proof -
have ‹Si_to_Sj i j x = P' j *⇩V Si_to_Sj i j x›
by (simp add: Si_to_Sj_def cblinfun_apply_cblinfun_compose[symmetric] register_mult P_butter P'_def)
also have ‹P' j *⇩V Si_to_Sj i j x ∈ space_as_set (S j)›
by (simp add: S_def)
finally show ?thesis by -
qed
have bij: ‹bij_betw (Si_to_Sj i j) (space_as_set (S i)) (space_as_set (S j))›
apply (rule bij_betwI[where g=‹Si_to_Sj j i›])
using S2S S2S2S by (auto intro!: funcsetI)
have ‹cdim (space_as_set (S i)) = cdim (space_as_set (S j))›
using lin apply (rule isomorphic_equal_cdim[where f=‹Si_to_Sj i j›])
using bij apply (auto simp: bij_betw_def)
by (metis complex_vector.span_span cspanB)
then show ?thesis
by (metis complex_vector.dim_span_eq_card_independent cspanB indepB)
qed
have CARD'b: ‹CARD('b) = card (B ξ0) * CARD('a)›
proof -
have ‹CARD('b) = card B'›
using cardB' by simp
also have ‹… = (∑i∈UNIV. card (B i))›
unfolding B'_def apply (rule card_UN_disjoint)
using finiteB Bdisj by auto
also have ‹… = (∑(i::'a)∈UNIV. card (B ξ0))›
using cardBsame by metis
also have ‹… = card (B ξ0) * CARD('a)›
by auto
finally show ?thesis by -
qed
obtain f where bij_f: ‹bij_betw f (UNIV::('a,'b) complement_domain set) (B ξ0)›
apply atomize_elim apply (rule finite_same_card_bij)
using finiteB CARD_complement_domain[OF CARD'b] by auto
define u where ‹u = (λ(ξ,α). Φ (butterket ξ ξ0) *⇩V f α)› for ξ :: 'a and α :: ‹('a,'b) complement_domain›
obtain U where Uapply: ‹U *⇩V ket ξα = u ξα› for ξα
apply atomize_elim
apply (rule exI[of _ ‹cblinfun_extension (range ket) (λk. u (inv ket k))›])
apply (subst cblinfun_extension_apply)
apply (rule cblinfun_extension_exists_finite_dim)
by (auto simp add: inj_ket cindependent_ket)
define eqa where ‹eqa a b = (if a = b then 1 else 0 :: complex)› for a b :: 'a
define eqc where ‹eqc a b = (if a = b then 1 else 0 :: complex)› for a b :: ‹('a,'b) complement_domain›
define eqac where ‹eqac a b = (if a = b then 1 else 0 :: complex)› for a b :: ‹'a * ('a,'b) complement_domain›
have ‹cinner (U *⇩V ket ξα) (U *⇩V ket ξ'α') = eqac ξα ξ'α'› for ξα ξ'α'
proof -
obtain ξ α ξ' α' where ξα: ‹ξα = (ξ,α)› and ξ'α': ‹ξ'α' = (ξ',α')›
apply atomize_elim by auto
have ‹cinner (U *⇩V ket (ξ,α)) (U *⇩V ket (ξ', α')) = cinner (Φ (butterket ξ ξ0) *⇩V f α) (Φ (butterket ξ' ξ0) *⇩V f α')›
unfolding Uapply u_def by simp
also have ‹… = cinner ((Φ (butterket ξ' ξ0))* *⇩V Φ (butterket ξ ξ0) *⇩V f α) (f α')›
by (simp add: cinner_adj_left)
also have ‹… = cinner (Φ (butterket ξ' ξ0 *) *⇩V Φ (butterket ξ ξ0) *⇩V f α) (f α')›
by (metis (no_types, lifting) assms register_def)
also have ‹… = cinner (Φ (butterket ξ0 ξ' o⇩C⇩L butterket ξ ξ0) *⇩V f α) (f α')›
by (simp add: register_mult cblinfun_apply_cblinfun_compose[symmetric])
also have ‹… = cinner (Φ (eqa ξ' ξ *⇩C selfbutterket ξ0) *⇩V f α) (f α')›
apply simp by (metis eqa_def cinner_ket)
also have ‹… = eqa ξ' ξ * cinner (Φ (selfbutterket ξ0) *⇩V f α) (f α')›
by (smt (verit, ccfv_threshold) ‹clinear Φ› eqa_def cblinfun.scaleC_left cinner_commute
cinner_scaleC_left cinner_zero_right complex_cnj_one complex_vector.linear_scale)
also have ‹… = eqa ξ' ξ * cinner (P' ξ0 *⇩V f α) (f α')›
using P_butter P'_def by simp
also have ‹… = eqa ξ' ξ * cinner (f α) (f α')›
apply (subst P'id)
apply (metis bij_betw_imp_surj_on bij_f complex_vector.span_base cspanB rangeI)
by simp
also have ‹… = eqa ξ' ξ * eqc α α'›
using bij_f orthoB normalB unfolding is_ortho_set_def eqc_def apply auto
apply (metis bij_betw_imp_surj_on cnorm_eq_1 rangeI)
by (smt (z3) bij_betw_iff_bijections iso_tuple_UNIV_I)
finally show ?thesis
by (simp add: eqa_def eqac_def eqc_def ξ'α' ξα)
qed
then have ‹isometry U›
apply (rule_tac orthogonal_on_basis_is_isometry[where B=‹range ket›])
using eqac_def by auto
have ‹U* o⇩C⇩L Φ (butterket ξ η) o⇩C⇩L U = butterket ξ η ⊗⇩o id_cblinfun› for ξ η
proof (rule equal_ket, rename_tac ξ1α)
fix ξ1α obtain ξ1 :: 'a and α :: ‹('a,'b) complement_domain› where ξ1α: ‹ξ1α = (ξ1,α)›
apply atomize_elim by auto
have ‹(U* o⇩C⇩L Φ (butterket ξ η) o⇩C⇩L U) *⇩V ket ξ1α = U* *⇩V Φ (butterket ξ η) *⇩V Φ (butterket ξ1 ξ0) *⇩V f α›
unfolding cblinfun_apply_cblinfun_compose ξ1α Uapply u_def by simp
also have ‹… = U* *⇩V Φ (butterket ξ η o⇩C⇩L butterket ξ1 ξ0) *⇩V f α›
by (metis (no_types, lifting) assms butterfly_comp_butterfly lift_cblinfun_comp(4) register_mult)
also have ‹… = U* *⇩V Φ (eqa η ξ1 *⇩C butterket ξ ξ0) *⇩V f α›
by (simp add: eqa_def cinner_ket)
also have ‹… = eqa η ξ1 *⇩C U* *⇩V Φ (butterket ξ ξ0) *⇩V f α›
by (simp add: complex_vector.linear_scale)
also have ‹… = eqa η ξ1 *⇩C U* *⇩V U *⇩V ket (ξ, α)›
unfolding Uapply u_def by simp
also from ‹isometry U› have ‹… = eqa η ξ1 *⇩C ket (ξ, α)›
unfolding cblinfun_apply_cblinfun_compose[symmetric] by simp
also have ‹… = (butterket ξ η *⇩V ket ξ1) ⊗⇩s ket α›
by (simp add: eqa_def tensor_ell2_scaleC1)
also have ‹… = (butterket ξ η ⊗⇩o id_cblinfun) *⇩V ket ξ1α›
by (simp add: ξ1α tensor_op_ket)
finally show ‹(U* o⇩C⇩L Φ (butterket ξ η) o⇩C⇩L U) *⇩V ket ξ1α = (butterket ξ η ⊗⇩o id_cblinfun) *⇩V ket ξ1α›
by -
qed
then have 1: ‹U* o⇩C⇩L Φ θ o⇩C⇩L U = θ ⊗⇩o id_cblinfun› for θ
apply (rule_tac clinear_eq_butterfly_ketI[THEN fun_cong, where x=θ])
by (auto intro!: clinearI simp add: bounded_cbilinear.add_left bounded_cbilinear_cblinfun_compose complex_vector.linear_add complex_vector.linear_scale)
have ‹unitary U›
proof -
have ‹Φ (butterket ξ ξ1) *⇩S ⊤ ≤ U *⇩S ⊤› for ξ ξ1
proof -
have *: ‹Φ (butterket ξ ξ0) *⇩V b ∈ space_as_set (U *⇩S ⊤)› if ‹b ∈ B ξ0› for b
apply (subst asm_rl[of ‹Φ (butterket ξ ξ0) *⇩V b = u (ξ, inv f b)›])
apply (simp add: u_def, metis bij_betw_inv_into_right bij_f that)
by (metis Uapply cblinfun_apply_in_image)
have ‹Φ (butterket ξ ξ1) *⇩S ⊤ = Φ (butterket ξ ξ0) *⇩S Φ (butterket ξ0 ξ0) *⇩S Φ (butterket ξ0 ξ1) *⇩S ⊤›
unfolding cblinfun_compose_image[symmetric] register_mult[OF assms]
by simp
also have ‹… ≤ Φ (butterket ξ ξ0) *⇩S Φ (butterket ξ0 ξ0) *⇩S ⊤›
by (meson cblinfun_image_mono top_greatest)
also have ‹… = Φ (butterket ξ ξ0) *⇩S S ξ0›
by (simp add: S_def P'_def P_butter)
also have ‹… = Φ (butterket ξ ξ0) *⇩S ccspan (B ξ0)›
by (simp add: ccspanB)
also have ‹… = ccspan (Φ (butterket ξ ξ0) ` B ξ0)›
by (meson cblinfun_image_ccspan)
also have ‹… ≤ U *⇩S ⊤›
by (rule ccspan_leqI, use * in auto)
finally show ?thesis by -
qed
moreover have ‹Φ id_cblinfun *⇩S ⊤ ≤ (SUP ξ∈UNIV. Φ (selfbutterket ξ) *⇩S ⊤)›
unfolding sum_butterfly_ket[symmetric]
apply (subst complex_vector.linear_sum, simp)
by (rule cblinfun_sum_image_distr)
ultimately have ‹Φ id_cblinfun *⇩S ⊤ ≤ U *⇩S ⊤›
apply auto by (meson SUP_le_iff order.trans)
then have ‹U *⇩S ⊤ = ⊤›
apply auto
using top.extremum_unique by blast
with ‹isometry U› show ‹unitary U›
by (rule surj_isometry_is_unitary)
qed
have ‹Φ θ = U o⇩C⇩L (θ ⊗⇩o id_cblinfun) o⇩C⇩L U*› for θ
proof -
from ‹unitary U›
have ‹Φ θ = (U o⇩C⇩L U*) o⇩C⇩L Φ θ o⇩C⇩L (U o⇩C⇩L U*)›
by simp
also have ‹… = U o⇩C⇩L (U* o⇩C⇩L Φ θ o⇩C⇩L U) o⇩C⇩L U*›
by (simp add: cblinfun_assoc_left)
also have ‹… = U o⇩C⇩L (θ ⊗⇩o id_cblinfun) o⇩C⇩L U*›
using 1 by simp
finally show ?thesis
by -
qed
with ‹unitary U› show ?thesis
by (auto simp: sandwich_def)
qed
lemma register_decomposition_converse:
assumes ‹unitary U›
shows ‹register (λx. sandwich U (id_cblinfun ⊗⇩o x))›
using _ unitary_sandwich_register apply (rule register_comp[unfolded o_def])
using assms by auto
lemma register_inj: ‹inj F› if ‹register F›
proof -
obtain U :: ‹('a × ('a, 'b) complement_domain) ell2 ⇒⇩C⇩L 'b ell2›
where ‹unitary U› and F: ‹F a = sandwich U (a ⊗⇩o id_cblinfun)› for a
apply atomize_elim using ‹register F› by (rule register_decomposition)
have ‹inj (sandwich U)›
by (smt (verit, best) ‹unitary U› cblinfun_assoc_left inj_onI sandwich_def cblinfun_compose_id_right cblinfun_compose_id_left unitary_def)
moreover have ‹inj (λa::'a::finite ell2 ⇒⇩C⇩L _. a ⊗⇩o id_cblinfun)›
by (rule inj_tensor_left, simp)
ultimately show ‹inj F›
unfolding F
by (smt (z3) inj_def)
qed
lemma iso_register_decomposition:
assumes [simp]: ‹iso_register F›
shows ‹∃U. unitary U ∧ F = sandwich U›
proof -
have [simp]: ‹register F›
using assms iso_register_is_register by blast
let ?ida = ‹id_cblinfun :: ('a, 'b) complement_domain ell2 ⇒⇩C⇩L _›
from register_decomposition[OF ‹register F›]
obtain V :: ‹('a × ('a, 'b) complement_domain) ell2 ⇒⇩C⇩L 'b ell2› where ‹unitary V›
and FV: ‹F θ = sandwich V (θ ⊗⇩o ?ida)› for θ
by auto
have ‹surj F›
by (meson assms iso_register_inv_comp2 surj_iff)
have surj_tensor: ‹surj (λa::'a ell2 ⇒⇩C⇩L 'a ell2. a ⊗⇩o ?ida)›
apply (rule surj_from_comp[where g=‹sandwich V›])
using ‹surj F› apply (auto simp: FV)
by (meson ‹unitary V› register_inj unitary_sandwich_register)
then obtain a :: ‹'a ell2 ⇒⇩C⇩L _›
where a: ‹a ⊗⇩o ?ida = selfbutterket undefined ⊗⇩o selfbutterket undefined›
by (smt (verit, best) surjD)
then have ‹a ≠ 0›
apply auto
by (metis butterfly_apply cblinfun.zero_left complex_vector.scale_eq_0_iff ket_nonzero orthogonal_ket)
obtain γ where γ: ‹?ida = γ *⇩C selfbutterket undefined›
apply atomize_elim
using a ‹a ≠ 0› by (rule tensor_op_almost_injective)
then have ‹?ida (ket undefined) = γ *⇩C (selfbutterket undefined *⇩V ket undefined)›
by (simp add: ‹id_cblinfun = γ *⇩C selfbutterket undefined› scaleC_cblinfun.rep_eq)
then have ‹ket undefined = γ *⇩C ket undefined›
by (metis butterfly_apply cinner_scaleC_right id_cblinfun_apply cinner_ket_same mult.right_neutral scaleC_one)
then have ‹γ = 1›
by (smt (z3) γ butterfly_apply butterfly_scaleC_left cblinfun_id_cblinfun_apply complex_vector.scale_cancel_right cinner_ket_same ket_nonzero)
define T U where ‹T = CBlinfun (λψ. ψ ⊗⇩s ket undefined)› and ‹U = V o⇩C⇩L T›
have T: ‹T ψ = ψ ⊗⇩s ket undefined› for ψ
unfolding T_def
apply (subst bounded_clinear_CBlinfun_apply)
by (auto intro!: bounded_clinear_finite_dim clinear_tensor_ell22)
have sandwich_T: ‹sandwich T a = a ⊗⇩o ?ida› for a
apply (rule fun_cong[where x=a])
apply (rule clinear_eq_butterfly_ketI)
apply auto
by (metis (no_types, opaque_lifting) Misc.sandwich_def T γ ‹γ = 1› adj_cblinfun_compose butterfly_adjoint cblinfun_comp_butterfly scaleC_one tensor_butterfly)
have ‹F (butterfly x y) = V o⇩C⇩L (butterfly x y ⊗⇩o ?ida) o⇩C⇩L V*› for x y
by (simp add: Misc.sandwich_def FV)
also have ‹… x y = V o⇩C⇩L (butterfly (T x) (T y)) o⇩C⇩L V*› for x y
by (simp add: T γ ‹γ = 1›)
also have ‹… x y = U o⇩C⇩L (butterfly x y) o⇩C⇩L U*› for x y
by (simp add: U_def butterfly_comp_cblinfun cblinfun_comp_butterfly)
finally have F_rep: ‹F a = U o⇩C⇩L a o⇩C⇩L U*› for a
apply (rule_tac fun_cong[where x=a])
apply (rule_tac clinear_eq_butterfly_ketI)
apply auto
by (metis (no_types, lifting) cblinfun_apply_clinear clinear_iff sandwich_apply)
have ‹isometry T›
apply (rule orthogonal_on_basis_is_isometry[where B=‹range ket›])
by (auto simp: T)
moreover have ‹T *⇩S ⊤ = ⊤›
proof -
have 1: ‹φ ⊗⇩s ξ ∈ range ((*⇩V) T)› for φ ξ
proof -
have ‹T *⇩V (cinner (ket undefined) ξ *⇩C φ) = φ ⊗⇩s (cinner (ket undefined) ξ *⇩C ket undefined)›
by (simp add: T tensor_ell2_scaleC2)
also have ‹… = φ ⊗⇩s (selfbutterket undefined *⇩V ξ)›
by simp
also have ‹… = φ ⊗⇩s (?ida *⇩V ξ)›
by (simp add: γ ‹γ = 1›)
also have ‹… = φ ⊗⇩s ξ›
by simp
finally show ?thesis
by (metis range_eqI)
qed
have ‹⊤ ≤ ccspan {ket x | x. True}›
by (simp add: full_SetCompr_eq)
also have ‹… ≤ ccspan {φ ⊗⇩s ξ | φ ξ. True}›
apply (rule ccspan_mono)
by (auto simp flip: tensor_ell2_ket)
also from 1 have ‹… ≤ ccspan (range ((*⇩V) T))›
by (auto intro!: ccspan_mono)
also have ‹… = T *⇩S ⊤›
by (metis (mono_tags, opaque_lifting) calculation cblinfun_image_ccspan cblinfun_image_mono eq_iff top_greatest)
finally show ‹T *⇩S ⊤ = ⊤›
using top.extremum_uniqueI by blast
qed
ultimately have ‹unitary T›
by (rule surj_isometry_is_unitary)
then have ‹unitary U›
by (simp add: U_def ‹unitary V›)
from F_rep ‹unitary U› show ?thesis
by (auto simp: sandwich_def[abs_def])
qed
lemma complement_exists:
fixes F :: ‹'a::finite update ⇒ 'b::finite update›
assumes ‹register F›
shows ‹∃G :: ('a, 'b) complement_domain update ⇒ 'b update. compatible F G ∧ iso_register (F;G)›
proof -
note [[simproc del: Laws_Quantum.compatibility_warn]]
obtain U :: ‹('a × ('a, 'b) complement_domain) ell2 ⇒⇩C⇩L 'b ell2›
where [simp]: "unitary U" and F: ‹F a = sandwich U (a ⊗⇩o id_cblinfun)› for a
apply atomize_elim using assms by (rule register_decomposition)
define G :: ‹(('a, 'b) complement_domain) update ⇒ 'b update› where ‹G b = sandwich U (id_cblinfun ⊗⇩o b)› for b
have [simp]: ‹register G›
unfolding G_def apply (rule register_decomposition_converse) by simp
have ‹F a o⇩C⇩L G b = G b o⇩C⇩L F a› for a b
proof -
have ‹F a o⇩C⇩L G b = sandwich U (a ⊗⇩o b)›
apply (auto simp: F G_def sandwich_def)
by (metis (no_types, lifting) ‹unitary U› isometryD cblinfun_assoc_left(1) comp_tensor_op cblinfun_compose_id_right cblinfun_compose_id_left unitary_isometry)
moreover have ‹G b o⇩C⇩L F a = sandwich U (a ⊗⇩o b)›
apply (auto simp: F G_def sandwich_def)
by (metis (no_types, lifting) ‹unitary U› isometryD cblinfun_assoc_left(1) comp_tensor_op cblinfun_compose_id_right cblinfun_compose_id_left unitary_isometry)
ultimately show ?thesis by simp
qed
then have [simp]: ‹compatible F G›
by (auto simp: compatible_def ‹register F› ‹register G›)
moreover have ‹iso_register (F;G)›
proof -
have ‹(F;G) (a ⊗⇩o b) = sandwich U (a ⊗⇩o b)› for a b
apply (auto simp: register_pair_apply F G_def sandwich_def)
by (metis (no_types, lifting) ‹unitary U› isometryD cblinfun_assoc_left(1) comp_tensor_op cblinfun_compose_id_right cblinfun_compose_id_left unitary_isometry)
then have FG: ‹(F;G) = sandwich U›
apply (rule tensor_extensionality[rotated -1])
by (simp_all add: bounded_cbilinear.add_left bounded_cbilinear_cblinfun_compose bounded_cbilinear.add_right clinearI)
define I where ‹I = sandwich (U*)› for x
have [simp]: ‹register I›
by (simp add: I_def unitary_sandwich_register)
have ‹I o (F;G) = id› and FGI: ‹(F;G) o I = id›
apply (auto intro!:ext simp: I_def[abs_def] FG sandwich_def)
apply (metis (no_types, opaque_lifting) ‹unitary U› isometryD cblinfun_assoc_left(1) cblinfun_compose_id_right cblinfun_compose_id_left unitary_isometry)
by (metis (no_types, lifting) ‹unitary U› cblinfun_assoc_left(1) cblinfun_compose_id_left cblinfun_compose_id_right unitaryD2)
then show ‹iso_register (F;G)›
by (auto intro!: iso_registerI)
qed
ultimately show ?thesis
apply (rule_tac exI[of _ G]) by (auto)
qed
definition ‹commutant F = {x. ∀y∈F. x o⇩C⇩L y = y o⇩C⇩L x}›
lemma commutant_exchange:
fixes F :: ‹'a::finite update ⇒ 'b::finite update›
assumes ‹iso_register F›
shows ‹commutant (F ` X) = F ` commutant X›
proof (rule Set.set_eqI)
fix x :: ‹'b update›
from assms
obtain G where ‹F o G = id› and ‹G o F = id› and [simp]: ‹register G›
using iso_register_def by blast
from assms have [simp]: ‹register F›
using iso_register_def by blast
have ‹x ∈ commutant (F ` X) ⟷ (∀y ∈ F ` X. x o⇩C⇩L y = y o⇩C⇩L x)›
by (simp add: commutant_def)
also have ‹… ⟷ (∀y ∈ F ` X. G x o⇩C⇩L G y = G y o⇩C⇩L G x)›
by (metis (no_types, opaque_lifting) ‹F ∘ G = id› ‹G o F = id› ‹register G› comp_def eq_id_iff register_def)
also have ‹… ⟷ (∀y ∈ X. G x o⇩C⇩L y = y o⇩C⇩L G x)›
by (simp add: ‹G ∘ F = id› pointfree_idE)
also have ‹… ⟷ G x ∈ commutant X›
by (simp add: commutant_def)
also have ‹… ⟷ x ∈ F ` commutant X›
by (metis (no_types, opaque_lifting) ‹G ∘ F = id› ‹F ∘ G = id› image_iff pointfree_idE)
finally show ‹x ∈ commutant (F ` X) ⟷ x ∈ F ` commutant X›
by -
qed
lemma commutant_tensor1: ‹commutant (range (λa. a ⊗⇩o id_cblinfun)) = range (λb. id_cblinfun ⊗⇩o b)›
proof (rule Set.set_eqI, rule iffI)
fix x :: ‹('a × 'b) ell2 ⇒⇩C⇩L ('a × 'b) ell2›
fix γ :: 'a
assume ‹x ∈ commutant (range (λa. a ⊗⇩o id_cblinfun))›
then have comm: ‹(a ⊗⇩o id_cblinfun) *⇩V x *⇩V ψ = x *⇩V (a ⊗⇩o id_cblinfun) *⇩V ψ› for a ψ
by (metis (mono_tags, lifting) commutant_def mem_Collect_eq rangeI cblinfun_apply_cblinfun_compose)
obtain x' where x': ‹cinner (ket j) (x' *⇩V ket l) = cinner (ket (γ,j)) (x *⇩V ket (γ,l))› for j l
proof atomize_elim
obtain ψ where ψ: ‹cinner (ket j) (ψ l) = cinner (ket (γ, j)) (x *⇩V ket (γ, l))› for l j
apply (atomize_elim, rule choice, rule allI)
apply (rule_tac x=‹Abs_ell2 (λj. cinner (ket (γ, j)) (x *⇩V ket (γ, l)))› in exI)
by (simp add: cinner_ket_left Abs_ell2_inverse)
obtain x' where ‹x' *⇩V ket l = ψ l› for l
apply atomize_elim
apply (rule exI[of _ ‹cblinfun_extension (range ket) (λl. ψ (inv ket l))›])
apply (subst cblinfun_extension_apply)
apply (rule cblinfun_extension_exists_finite_dim)
by (auto simp add: inj_ket cindependent_ket)
with ψ have ‹cinner (ket j) (x' *⇩V ket l) = cinner (ket (γ, j)) (x *⇩V ket (γ, l))› for j l
by auto
then show ‹∃x'. ∀j l. cinner (ket j) (x' *⇩V ket l) = cinner (ket (γ, j)) (x *⇩V ket (γ, l))›
by auto
qed
have ‹cinner (ket (i,j)) (x *⇩V ket (k,l)) = cinner (ket (i,j)) ((id_cblinfun ⊗⇩o x') *⇩V ket (k,l))› for i j k l
proof -
have ‹cinner (ket (i,j)) (x *⇩V ket (k,l))
= cinner ((butterket i γ ⊗⇩o id_cblinfun) *⇩V ket (γ,j)) (x *⇩V (butterket k γ ⊗⇩o id_cblinfun) *⇩V ket (γ,l))›
by (auto simp: tensor_op_ket)
also have ‹… = cinner (ket (γ,j)) ((butterket γ i ⊗⇩o id_cblinfun) *⇩V x *⇩V (butterket k γ ⊗⇩o id_cblinfun) *⇩V ket (γ,l))›
by (metis (no_types, lifting) cinner_adj_left butterfly_adjoint id_cblinfun_adjoint tensor_op_adjoint)
also have ‹… = cinner (ket (γ,j)) (x *⇩V (butterket γ i ⊗⇩o id_cblinfun o⇩C⇩L butterket k γ ⊗⇩o id_cblinfun) *⇩V ket (γ,l))›
unfolding comm by (simp add: cblinfun_apply_cblinfun_compose)
also have ‹… = cinner (ket i) (ket k) * cinner (ket (γ,j)) (x *⇩V ket (γ,l))›
by (simp add: comp_tensor_op tensor_op_ket tensor_op_scaleC_left)
also have ‹… = cinner (ket i) (ket k) * cinner (ket j) (x' *⇩V ket l)›
by (simp add: x')
also have ‹… = cinner (ket (i,j)) ((id_cblinfun ⊗⇩o x') *⇩V ket (k,l))›
apply (simp add: tensor_op_ket)
by (simp flip: tensor_ell2_ket)
finally show ?thesis by -
qed
then have ‹x = (id_cblinfun ⊗⇩o x')›
by (auto intro!: equal_ket cinner_ket_eqI)
then show ‹x ∈ range (λb. id_cblinfun ⊗⇩o b)›
by auto
next
fix x :: ‹('a × 'b) ell2 ⇒⇩C⇩L ('a × 'b) ell2›
assume ‹x ∈ range (λb. id_cblinfun ⊗⇩o b)›
then obtain b where x: ‹x = id_cblinfun ⊗⇩o b›
by auto
then show ‹x ∈ commutant (range (λa. a ⊗⇩o id_cblinfun))›
by (auto simp: x commutant_def comp_tensor_op)
qed
lemma complement_range:
assumes [simp]: ‹compatible F G› and [simp]: ‹iso_register (F;G)›
shows ‹range G = commutant (range F)›
proof -
have [simp]: ‹register F› ‹register G›
using assms compatible_def by metis+
have [simp]: ‹(F;G) (a ⊗⇩o b) = F a o⇩C⇩L G b› for a b
using Laws_Quantum.register_pair_apply assms by blast
have [simp]: ‹range F = (F;G) ` range (λa. a ⊗⇩o id_cblinfun)›
by force
have [simp]: ‹range G = (F;G) ` range (λb. id_cblinfun ⊗⇩o b)›
by force
show ‹range G = commutant (range F)›
by (simp add: commutant_exchange commutant_tensor1)
qed
lemma same_range_equivalent:
fixes F :: ‹'a::finite update ⇒ 'c::finite update› and G :: ‹'b::finite update ⇒ 'c::finite update›
assumes [simp]: ‹register F› and [simp]: ‹register G›
assumes ‹range F = range G›
shows ‹equivalent_registers F G›
proof -
have G_rangeF[simp]: ‹G x ∈ range F› for x
by (simp add: assms)
have F_rangeG[simp]: ‹F x ∈ range G› for x
by (simp add: assms(3)[symmetric])
have [simp]: ‹inj F› and [simp]: ‹inj G›
by (simp_all add: register_inj)
have [simp]: ‹clinear F› ‹clinear G›
by simp_all
define I J where ‹I x = inv F (G x)› and ‹J y = inv G (F y)› for x y
have addI: ‹I (x + y) = I x + I y› for x y
unfolding I_def
apply (rule injD[OF ‹inj F›])
apply (subst complex_vector.linear_add[OF ‹clinear F›])
apply (subst Hilbert_Choice.f_inv_into_f[where f=F], simp)+
by (simp add: complex_vector.linear_add)
have addJ: ‹J (x + y) = J x + J y› for x y
unfolding J_def
apply (rule injD[OF ‹inj G›])
apply (subst complex_vector.linear_add[OF ‹clinear G›])
apply (subst Hilbert_Choice.f_inv_into_f[where f=G], simp)+
by (simp add: complex_vector.linear_add)
have scaleI: ‹I (r *⇩C x) = r *⇩C I x› for r x
unfolding I_def
apply (rule injD[OF ‹inj F›])
apply (subst complex_vector.linear_scale[OF ‹clinear F›])
apply (subst Hilbert_Choice.f_inv_into_f[where f=F], simp)+
by (simp add: complex_vector.linear_scale)
have scaleJ: ‹J (r *⇩C x) = r *⇩C J x› for r x
unfolding J_def
apply (rule injD[OF ‹inj G›])
apply (subst complex_vector.linear_scale[OF ‹clinear G›])
apply (subst Hilbert_Choice.f_inv_into_f[where f=G], simp)+
by (simp add: complex_vector.linear_scale)
have unitalI: ‹I id_cblinfun = id_cblinfun›
unfolding I_def
apply (rule injD[OF ‹inj F›])
apply (subst Hilbert_Choice.f_inv_into_f[where f=F])
apply auto
by (metis register_of_id G_rangeF assms(2))
have unitalJ: ‹J id_cblinfun = id_cblinfun›
unfolding J_def
apply (rule injD[OF ‹inj G›])
apply (subst Hilbert_Choice.f_inv_into_f[where f=G])
apply auto
by (metis register_of_id F_rangeG assms(1))
have multI: ‹I (a o⇩C⇩L b) = I a o⇩C⇩L I b› for a b
unfolding I_def
apply (rule injD[OF ‹inj F›])
apply (subst register_mult[symmetric, OF ‹register F›])
apply (subst Hilbert_Choice.f_inv_into_f[where f=F], simp)+
by (simp add: register_mult)
have multJ: ‹J (a o⇩C⇩L b) = J a o⇩C⇩L J b› for a b
unfolding J_def
apply (rule injD[OF ‹inj G›])
apply (subst register_mult[symmetric, OF ‹register G›])
apply (subst Hilbert_Choice.f_inv_into_f[where f=G], simp)+
by (simp add: register_mult)
have adjI: ‹I (a*) = (I a)*› for a
unfolding I_def
apply (rule injD[OF ‹inj F›])
apply (subst register_adjoint[OF ‹register F›])
apply (subst Hilbert_Choice.f_inv_into_f[where f=F], simp)+
using assms(2) register_adjoint by blast
have adjJ: ‹J (a*) = (J a)*› for a
unfolding J_def
apply (rule injD[OF ‹inj G›])
apply (subst register_adjoint[OF ‹register G›])
apply (subst Hilbert_Choice.f_inv_into_f[where f=G], simp)+
using assms(1) register_adjoint by blast
from addI scaleI unitalI multI adjI
have ‹register I›
unfolding register_def by (auto intro!: clinearI)
from addJ scaleJ unitalJ multJ adjJ
have ‹register J›
unfolding register_def by (auto intro!: clinearI)
have ‹I o J = id›
unfolding I_def J_def o_def
apply (subst Hilbert_Choice.f_inv_into_f[where f=G], simp)
apply (subst Hilbert_Choice.inv_f_f[OF ‹inj F›])
by auto
have ‹J o I = id›
unfolding I_def J_def o_def
apply (subst Hilbert_Choice.f_inv_into_f[where f=F], simp)
apply (subst Hilbert_Choice.inv_f_f[OF ‹inj G›])
by auto
from ‹I o J = id› ‹J o I = id› ‹register I› ‹register J›
have ‹iso_register I›
using iso_register_def by blast
have ‹F o I = G›
unfolding I_def o_def
by (subst Hilbert_Choice.f_inv_into_f[where f=F], auto)
with ‹iso_register I› show ?thesis
unfolding equivalent_registers_def by auto
qed
lemma complement_unique:
assumes "compatible F G" and ‹iso_register (F;G)›
assumes "compatible F H" and ‹iso_register (F;H)›
shows ‹equivalent_registers G H›
by (metis assms compatible_def complement_range same_range_equivalent)
end
Theory Laws_Complement_Quantum
section ‹Generic laws about complements, instantiated quantumly›
theory Laws_Complement_Quantum
imports Laws_Quantum Axioms_Complement_Quantum
begin
notation cblinfun_compose (infixl "*⇩u" 55)
notation tensor_op (infixr "⊗⇩u" 70)
definition ‹complements F G ⟷ compatible F G ∧ iso_register (F;G)›
lemma complementsI: ‹compatible F G ⟹ iso_register (F;G) ⟹ complements F G›
using complements_def by blast
lemma complements_sym: ‹complements G F› if ‹complements F G›
proof (rule complementsI)
show [simp]: ‹compatible G F›
using compatible_sym complements_def that by blast
from that have ‹iso_register (F;G)›
by (meson complements_def)
then obtain I where [simp]: ‹register I› and ‹(F;G) o I = id› and ‹I o (F;G) = id›
using iso_register_def by blast
have ‹register (swap o I)›
using ‹register I› register_comp register_swap by blast
moreover have ‹(G;F) o (swap o I) = id›
by (simp add: ‹(F;G) ∘ I = id› rewriteL_comp_comp)
moreover have ‹(swap o I) o (G;F) = id›
by (metis (no_types, opaque_lifting) swap_swap ‹I ∘ (F;G) = id› calculation(2) comp_def eq_id_iff)
ultimately show ‹iso_register (G;F)›
using ‹compatible G F› iso_register_def pair_is_register by blast
qed
definition complement :: ‹('a::finite update ⇒ 'b::finite update) ⇒ (('a,'b) complement_domain update ⇒ 'b update)› where
‹complement F = (SOME G :: ('a, 'b) complement_domain update ⇒ 'b update. compatible F G ∧ iso_register (F;G))›
lemma register_complement[simp]: ‹register (complement F)› if ‹register F›
using complement_exists[OF that]
by (metis (no_types, lifting) compatible_def complement_def some_eq_imp)
lemma complement_is_complement:
assumes ‹register F›
shows ‹complements F (complement F)›
using complement_exists[OF assms] unfolding complements_def
by (metis (mono_tags, lifting) complement_def some_eq_imp)
lemma complement_unique:
assumes ‹complements F G›
shows ‹equivalent_registers G (complement F)›
apply (rule complement_unique[where F=F])
using assms unfolding complements_def using compatible_register1 complement_is_complement complements_def by blast+
lemma compatible_complement[simp]: ‹register F ⟹ compatible F (complement F)›
using complement_is_complement complements_def by blast
lemma complements_register_tensor:
assumes [simp]: ‹register F› ‹register G›
shows ‹complements (F ⊗⇩r G) (complement F ⊗⇩r complement G)›
proof (rule complementsI)
have sep4: ‹separating TYPE('z::finite) {(a ⊗⇩u b) ⊗⇩u (c ⊗⇩u d) |a b c d. True}›
apply (rule separating_tensor'[where A=‹{(a ⊗⇩u b) |a b. True}› and B=‹{(c ⊗⇩u d) |c d. True}›])
apply (rule separating_tensor'[where A=UNIV and B=UNIV]) apply auto[3]
apply (rule separating_tensor'[where A=UNIV and B=UNIV]) apply auto[3]
by auto
show compat: ‹compatible (F ⊗⇩r G) (complement F ⊗⇩r complement G)›
by (metis assms(1) assms(2) compatible_register_tensor complement_is_complement complements_def)
let ?reorder = ‹((Fst o Fst; Snd o Fst); (Fst o Snd; Snd o Snd))›
have [simp]: ‹register ?reorder›
by auto
have [simp]: ‹?reorder ((a ⊗⇩u b) ⊗⇩u (c ⊗⇩u d)) = ((a ⊗⇩u c) ⊗⇩u (b ⊗⇩u d))›
for a::‹'t::finite update› and b::‹'u::finite update› and c::‹'v::finite update› and d::‹'w::finite update›
by (simp add: register_pair_apply Fst_def Snd_def comp_tensor_op)
have [simp]: ‹iso_register ?reorder›
apply (rule iso_registerI[of _ ?reorder]) apply auto[2]
apply (rule register_eqI[OF sep4]) apply auto[3]
apply (rule register_eqI[OF sep4]) by auto
have ‹(F ⊗⇩r G; complement F ⊗⇩r complement G) = ((F; complement F) ⊗⇩r (G; complement G)) o ?reorder›
apply (rule register_eqI[OF sep4])
by (auto intro!: register_preregister register_comp register_tensor_is_register pair_is_register
simp: compat register_pair_apply comp_tensor_op)
moreover have ‹iso_register …›
apply (auto intro!: iso_register_comp iso_register_tensor_is_iso_register)
using assms complement_is_complement complements_def by blast+
ultimately show ‹iso_register (F ⊗⇩r G;complement F ⊗⇩r complement G)›
by simp
qed
definition is_unit_register where
‹is_unit_register U ⟷ complements U id›
lemma register_unit_register[simp]: ‹is_unit_register U ⟹ register U›
by (simp add: compatible_def complements_def is_unit_register_def)
lemma unit_register_compatible[simp]: ‹compatible U X› if ‹is_unit_register U› ‹register X›
by (metis compatible_comp_right complements_def id_comp is_unit_register_def that(1) that(2))
lemma unit_register_compatible'[simp]: ‹compatible X U› if ‹is_unit_register U› ‹register X›
using compatible_sym that(1) that(2) unit_register_compatible by blast
lemma compatible_complement_left[simp]: ‹register X ⟹ compatible (complement X) X›
using compatible_sym complement_is_complement complements_def by blast
lemma compatible_complement_right[simp]: ‹register X ⟹ compatible X (complement X)›
using complement_is_complement complements_def by blast
lemma unit_register_pair[simp]: ‹equivalent_registers X (U; X)› if [simp]: ‹is_unit_register U› ‹register X›
proof -
have ‹equivalent_registers id (U; id)›
using complements_def is_unit_register_def iso_register_equivalent_id that(1) by blast
also have ‹equivalent_registers … (U; (X; complement X))›
apply (rule equivalent_registers_pair_right)
apply (auto intro!: unit_register_compatible)
using complement_is_complement complements_def equivalent_registersI id_comp register_id that(2) by blast
also have ‹equivalent_registers … ((U; X); complement X)›
apply (rule equivalent_registers_assoc)
by auto
finally have ‹complements (U; X) (complement X)›
by (auto simp: equivalent_registers_def complements_def)
moreover have ‹equivalent_registers (X; complement X) id›
by (metis complement_is_complement complements_def equivalent_registers_def iso_register_def that)
ultimately show ?thesis
by (meson complement_unique complement_is_complement complements_sym equivalent_registers_sym equivalent_registers_trans that)
qed
lemma unit_register_compose_left:
assumes [simp]: ‹is_unit_register U›
assumes [simp]: ‹register A›
shows ‹is_unit_register (A o U)›
proof -
have ‹compatible (A o U) (A; complement A)›
apply (auto intro!: compatible3')
by (metis assms(1) assms(2) comp_id compatible_comp_inner complements_def is_unit_register_def)
then have compat[simp]: ‹compatible (A o U) id›
by (metis assms(2) compatible_comp_right complement_is_complement complements_def iso_register_def)
have ‹equivalent_registers (A o U; id) (A o U; (A; complement A))›
apply (auto intro!: equivalent_registers_pair_right)
using assms(2) complement_is_complement complements_def equivalent_registers_def id_comp register_id by blast
also have ‹equivalent_registers … ((A o U; A o id); complement A)›
apply auto
by (metis (no_types, opaque_lifting) compat assms(1) assms(2) compatible_comp_left compatible_def compatible_register1 complement_is_complement complements_def equivalent_registers_assoc id_apply register_unit_register)
also have ‹equivalent_registers … (A o (U; id); complement A)›
by (metis (no_types, opaque_lifting) assms(1) assms(2) calculation complements_def equivalent_registers_sym equivalent_registers_trans is_unit_register_def register_comp_pair)
also have ‹equivalent_registers … (A o id; complement A)›
apply (intro equivalent_registers_pair_left equivalent_registers_comp)
apply (auto simp: assms)
using assms(1) equivalent_registers_sym register_id unit_register_pair by blast
also have ‹equivalent_registers … id›
by (metis assms(2) comp_id complement_is_complement complements_def equivalent_registers_def iso_register_inv iso_register_inv_comp2 pair_is_register)
finally show ?thesis
using compat complementsI equivalent_registers_sym is_unit_register_def iso_register_equivalent_id by blast
qed
lemma unit_register_compose_right:
assumes [simp]: ‹is_unit_register U›
assumes [simp]: ‹iso_register A›
shows ‹is_unit_register (U o A)›
proof (unfold is_unit_register_def, rule complementsI)
show ‹compatible (U ∘ A) id›
by (simp add: iso_register_is_register)
have 1: ‹iso_register ((U;id) ∘ A ⊗⇩r id)›
by (meson assms(1) assms(2) complements_def is_unit_register_def iso_register_comp iso_register_id iso_register_tensor_is_iso_register)
have 2: ‹id ∘ ((U;id) ∘ A ⊗⇩r id) = (U ∘ A;id)›
by (metis assms(1) assms(2) complements_def fun.map_id is_unit_register_def iso_register_id iso_register_is_register pair_o_tensor)
show ‹iso_register (U ∘ A;id)›
using 1 2 by auto
qed
lemma unit_register_unique:
assumes ‹is_unit_register F›
assumes ‹is_unit_register G›
shows ‹equivalent_registers F G›
proof -
have ‹complements F id› ‹complements G id›
using assms by (metis complements_def equivalent_registers_def id_comp is_unit_register_def)+
then show ?thesis
by (meson complement_unique complements_sym equivalent_registers_sym equivalent_registers_trans)
qed
lemma unit_register_domains_isomorphic:
fixes F :: ‹'a::finite update ⇒ 'c::finite update›
fixes G :: ‹'b::finite update ⇒ 'd::finite update›
assumes ‹is_unit_register F›
assumes ‹is_unit_register G›
shows ‹∃I :: 'a update ⇒ 'b update. iso_register I›
proof -
have ‹is_unit_register ((λd. tensor_op id_cblinfun d) o G)›
by (simp add: assms(2) unit_register_compose_left)
moreover have ‹is_unit_register ((λc. tensor_op c id_cblinfun) o F)›
using assms(1) register_tensor_left unit_register_compose_left by blast
ultimately have ‹equivalent_registers ((λd. tensor_op id_cblinfun d) o G) ((λc. tensor_op c id_cblinfun) o F)›
using unit_register_unique by blast
then show ?thesis
unfolding equivalent_registers_def by auto
qed
lemma id_complement_is_unit_register[simp]: ‹is_unit_register (complement id)›
by (metis is_unit_register_def complement_is_complement complements_def complements_sym equivalent_registers_def id_comp register_id)
type_synonym unit_register_domain = ‹(unit, unit) complement_domain›
definition unit_register :: ‹unit_register_domain update ⇒ 'a::finite update› where ‹unit_register = (SOME U. is_unit_register U)›
lemma unit_register_is_unit_register[simp]: ‹is_unit_register (unit_register :: unit_register_domain update ⇒ 'a::finite update)›
proof -
let ?U0 = ‹complement id :: unit_register_domain update ⇒ unit update›
let ?U1 = ‹complement id :: ('a, 'a) complement_domain update ⇒ 'a update›
have ‹is_unit_register ?U0› ‹is_unit_register ?U1›
by auto
then obtain I :: ‹unit_register_domain update ⇒ ('a, 'a) complement_domain update› where ‹iso_register I›
apply atomize_elim by (rule unit_register_domains_isomorphic)
with ‹is_unit_register ?U1› have ‹is_unit_register (?U1 o I)›
by (rule unit_register_compose_right)
then show ?thesis
by (metis someI_ex unit_register_def)
qed
lemma unit_register_domain_tensor_unit:
fixes U :: ‹'a::finite update ⇒ _›
assumes ‹is_unit_register U›
shows ‹∃I :: 'b::finite update ⇒ ('a*'b) update. iso_register I›
proof -
have ‹equivalent_registers (id :: 'b update ⇒ _) (complement id; id)›
using id_complement_is_unit_register iso_register_equivalent_id register_id unit_register_pair by blast
then obtain J :: ‹'b update ⇒ ((('b, 'b) complement_domain * 'b) update)› where ‹iso_register J›
using equivalent_registers_def iso_register_inv by blast
moreover obtain K :: ‹('b, 'b) complement_domain update ⇒ 'a update› where ‹iso_register K›
using assms id_complement_is_unit_register unit_register_domains_isomorphic by blast
ultimately have ‹iso_register ((K ⊗⇩r id) o J)›
by auto
then show ?thesis
by auto
qed
lemma compatible_complement_pair1:
assumes ‹compatible F G›
shows ‹compatible F (complement (F;G))›
by (metis assms compatible_comp_left compatible_complement_right pair_is_register register_Fst register_pair_Fst)
lemma compatible_complement_pair2:
assumes [simp]: ‹compatible F G›
shows ‹compatible G (complement (F;G))›
proof -
have ‹compatible (F;G) (complement (F;G))›
by simp
then have ‹compatible ((F;G) o Snd) (complement (F;G))›
by auto
then show ?thesis
by (auto simp: register_pair_Snd)
qed
lemma equivalent_complements:
assumes ‹complements F G›
assumes ‹equivalent_registers G G'›
shows ‹complements F G'›
apply (rule complementsI)
apply (metis assms(1) assms(2) compatible_comp_right complements_def equivalent_registers_def iso_register_is_register)
by (metis assms(1) assms(2) complements_def equivalent_registers_def equivalent_registers_pair_right iso_register_comp)
lemma complements_complement_pair:
assumes [simp]: ‹compatible F G›
shows ‹complements F (G; complement (F;G))›
proof (rule complementsI)
have ‹equivalent_registers (F; (G; complement (F;G))) ((F;G); complement (F;G))›
apply (rule equivalent_registers_assoc)
by (auto simp add: compatible_complement_pair1 compatible_complement_pair2)
also have ‹equivalent_registers … id›
by (meson assms complement_is_complement complements_def equivalent_registers_sym iso_register_equivalent_id pair_is_register)
finally show ‹iso_register (F;(G;complement (F;G)))›
using equivalent_registers_sym iso_register_equivalent_id by blast
show ‹compatible F (G;complement (F;G))›
using assms compatible3' compatible_complement_pair1 compatible_complement_pair2 by blast
qed
lemma equivalent_registers_complement:
assumes ‹equivalent_registers F G›
shows ‹equivalent_registers (complement F) (complement G)›
proof -
have ‹complements F (complement F)›
using assms complement_is_complement equivalent_registers_register_left by blast
with assms have ‹complements G (complement F)›
by (meson complements_sym equivalent_complements)
then show ?thesis
by (rule complement_unique)
qed
lemma complements_complement_pair':
assumes [simp]: ‹compatible F G›
shows ‹complements G (F; complement (F;G))›
proof -
have ‹equivalent_registers (F;G) (G;F)›
apply (rule equivalent_registersI[where I=swap])
by auto
then have ‹equivalent_registers (complement (F;G)) (complement (G;F))›
by (rule equivalent_registers_complement)
then have ‹equivalent_registers (F; (complement (F;G))) (F; (complement (G;F)))›
apply (rule equivalent_registers_pair_right[rotated])
using assms compatible_complement_pair1 by blast
moreover have ‹complements G (F; complement (G;F))›
apply (rule complements_complement_pair)
using assms compatible_sym by blast
ultimately show ?thesis
by (meson equivalent_complements equivalent_registers_sym)
qed
lemma complements_chain:
assumes [simp]: ‹register F› ‹register G›
shows ‹complements (F o G) (complement F; F o complement G)›
proof (rule complementsI)
show ‹compatible (F o G) (complement F; F o complement G)›
by auto
have ‹equivalent_registers (F ∘ G;(complement F;F ∘ complement G)) (F ∘ G;(F ∘ complement G;complement F))›
apply (rule equivalent_registersI[where I=‹id ⊗⇩r swap›])
by (auto intro!: iso_register_tensor_is_iso_register simp: pair_o_tensor)
also have ‹equivalent_registers … ((F ∘ G;F ∘ complement G);complement F)›
apply (rule equivalent_registersI[where I=assoc])
by (auto intro!: iso_register_tensor_is_iso_register simp: pair_o_tensor)
also have ‹equivalent_registers … (F o (G; complement G);complement F)›
by (metis (no_types, lifting) assms(1) assms(2) calculation compatible_complement_right
equivalent_registers_sym equivalent_registers_trans register_comp_pair)
also have ‹equivalent_registers … (F o id;complement F)›
apply (rule equivalent_registers_pair_left, simp)
apply (rule equivalent_registers_comp, simp)
by (metis assms(2) complement_is_complement complements_def equivalent_registers_def iso_register_def)
also have ‹equivalent_registers … id›
by (metis assms(1) comp_id complement_is_complement complements_def equivalent_registers_def iso_register_def)
finally show ‹iso_register (F ∘ G;(complement F;F ∘ complement G))›
using equivalent_registers_sym iso_register_equivalent_id by blast
qed
lemma complements_Fst_Snd[simp]: ‹complements Fst Snd›
by (auto intro!: complementsI simp: pair_Fst_Snd)
lemma complements_Snd_Fst[simp]: ‹complements Snd Fst›
by (auto intro!: complementsI simp flip: swap_def)
lemma compatible_unit_register[simp]: ‹register F ⟹ compatible F unit_register›
using compatible_sym unit_register_compatible unit_register_is_unit_register by blast
lemma complements_id_unit_register[simp]: ‹complements id unit_register›
using complements_sym is_unit_register_def unit_register_is_unit_register by blast
lemma complements_iso_unit_register: ‹iso_register I ⟹ is_unit_register U ⟹ complements I U›
using complements_sym equivalent_complements is_unit_register_def iso_register_equivalent_id by blast
lemma iso_register_complement_is_unit_register[simp]:
assumes ‹iso_register F›
shows ‹is_unit_register (complement F)›
by (meson assms complement_is_complement complements_sym equivalent_complements equivalent_registers_sym is_unit_register_def iso_register_equivalent_id iso_register_is_register)
text ‹Adding support for \<^term>‹is_unit_register F› and \<^term>‹complements F G› to the [@{attribute register}] attribute›
lemmas [register_attribute_rule] = is_unit_register_def[THEN iffD1] complements_def[THEN iffD1]
lemmas [register_attribute_rule_immediate] = asm_rl[of ‹is_unit_register _›]
no_notation cblinfun_compose (infixl "*⇩u" 55)
no_notation tensor_op (infixr "⊗⇩u" 70)
end
Theory Pure_States
theory Pure_States
imports Quantum_Extra2 "HOL-Eisbach.Eisbach"
begin
definition ‹pure_state_target_vector F η⇩F = (if ket default ∈ range (cblinfun_apply (F (butterfly η⇩F η⇩F)))
then ket default
else (SOME η'. norm η' = 1 ∧ η' ∈ range (cblinfun_apply (F (butterfly η⇩F η⇩F)))))›
lemma pure_state_target_vector_eqI:
assumes ‹F (butterfly η⇩F η⇩F) = G (butterfly η⇩G η⇩G)›
shows ‹pure_state_target_vector F η⇩F = pure_state_target_vector G η⇩G›
by (simp add: assms pure_state_target_vector_def)
lemma pure_state_target_vector_ket_default: ‹pure_state_target_vector F η⇩F = ket default› if ‹ket default ∈ range (cblinfun_apply (F (butterfly η⇩F η⇩F)))›
by (simp add: pure_state_target_vector_def that)
lemma
assumes [simp]: ‹η⇩F ≠ 0› ‹register F›
shows pure_state_target_vector_in_range: ‹pure_state_target_vector F η⇩F ∈ range ((*⇩V) (F (selfbutter η⇩F)))› (is ?range)
and pure_state_target_vector_norm: ‹norm (pure_state_target_vector F η⇩F) = 1› (is ?norm)
proof -
from assms have ‹selfbutter η⇩F ≠ 0›
by (metis butterfly_0_right complex_vector.scale_zero_right inj_selfbutter_upto_phase)
then have ‹F (selfbutter η⇩F) ≠ 0›
using register_inj[OF ‹register F›, THEN injD, where y=0]
by (auto simp: complex_vector.linear_0)
then obtain ψ' where ψ': ‹F (selfbutter η⇩F) *⇩V ψ' ≠ 0›
by (meson cblinfun_eq_0_on_UNIV_span complex_vector.span_UNIV)
have ex: ‹∃ψ. norm ψ = 1 ∧ ψ ∈ range ((*⇩V) (F (selfbutter η⇩F)))›
apply (rule exI[of _ ‹(F (selfbutter η⇩F) *⇩V ψ') /⇩C norm (F (selfbutter η⇩F) *⇩V ψ')›])
using ψ' apply (auto simp add: norm_inverse)
by (metis cblinfun.scaleC_right rangeI)
then show ?range
by (metis (mono_tags, lifting) pure_state_target_vector_def verit_sko_ex')
show ?norm
apply (simp add: pure_state_target_vector_def)
using ex by (metis (mono_tags, lifting) verit_sko_ex')
qed
lemma pure_state_target_vector_correct:
assumes [simp]: ‹η ≠ 0› ‹register F›
shows ‹F (selfbutter η) *⇩V pure_state_target_vector F η ≠ 0›
proof -
obtain ψ where ψ: ‹F (selfbutter η) ψ = pure_state_target_vector F η›
apply atomize_elim
using pure_state_target_vector_in_range[OF assms]
by (smt (verit, best) image_iff top_ccsubspace.rep_eq top_set_def)
define n where ‹n = cinner η η›
then have ‹n ≠ 0›
by auto
have pure_state_target_vector_neq0: ‹pure_state_target_vector F η ≠ 0›
using pure_state_target_vector_norm[OF assms]
by auto
have ‹F (selfbutter η) *⇩V pure_state_target_vector F η = F (selfbutter η) *⇩V F (selfbutter η) *⇩V ψ›
by (simp add: ψ)
also have ‹… = n *⇩C F (selfbutter η) *⇩V ψ›
by (simp flip: cblinfun_apply_cblinfun_compose add: register_mult register_scaleC n_def)
also have ‹… = n *⇩C pure_state_target_vector F η›
by (simp add: ψ)
also have ‹… ≠ 0›
using pure_state_target_vector_neq0 ‹n ≠ 0›
by auto
finally show ?thesis
by -
qed
definition ‹pure_state' F ψ η⇩F = F (butterfly ψ η⇩F) *⇩V pure_state_target_vector F η⇩F›
abbreviation ‹pure_state F ψ ≡ pure_state' F ψ (ket default)›
nonterminal pure_tensor
syntax "_pure_tensor" :: ‹'a ⇒ 'b ⇒ pure_tensor ⇒ pure_tensor› ("_ _ ⊗⇩p _" [1000, 0, 0] 1000)
syntax "_pure_tensor2" :: ‹'a ⇒ 'b ⇒ 'c ⇒ 'd ⇒ pure_tensor› ("_ _ ⊗⇩p _ _" [1000, 0, 1000, 0] 1000)
syntax "_pure_tensor1" :: ‹'a ⇒ 'b ⇒ pure_tensor›
syntax "_pure_tensor_start" :: ‹pure_tensor ⇒ 'a› ("'(_')")
translations
"_pure_tensor2 F ψ G φ" ⇀ "CONST pure_state (F; G) (ψ ⊗⇩s φ)"
"_pure_tensor F ψ (CONST pure_state G φ)" ⇀ "CONST pure_state (F; G) (ψ ⊗⇩s φ)"
"_pure_tensor_start x" ⇀ "x"
"_pure_tensor_start (_pure_tensor2 F ψ G φ)" ↽ "CONST pure_state (F; G) (ψ ⊗⇩s φ)"
"_pure_tensor F ψ (_pure_tensor2 G φ H η)" ↽ "_pure_tensor2 F ψ (G;H) (φ ⊗⇩s η)"
term ‹(F ψ ⊗⇩p G φ ⊗⇩p H z)›
term ‹pure_state (F; G) (a ⊗⇩s b)›
lemma register_pair_butterfly_tensor: ‹(F; G) (butterfly (a ⊗⇩s b) (c ⊗⇩s d)) = F (butterfly a c) o⇩C⇩L G (butterfly b d)›
if [simp]: ‹compatible F G›
by (auto simp: default_prod_def simp flip: tensor_ell2_ket tensor_butterfly register_pair_apply)
lemma pure_state_eqI:
assumes ‹F (selfbutter η⇩F) = G (selfbutter η⇩G)›
assumes ‹F (butterfly ψ η⇩F) = G (butterfly φ η⇩G)›
shows ‹pure_state' F ψ η⇩F = pure_state' G φ η⇩G›
proof -
from assms(1) have ‹pure_state_target_vector F η⇩F = pure_state_target_vector G η⇩G›
by (rule pure_state_target_vector_eqI)
with assms(2)
show ?thesis
unfolding pure_state'_def
by simp
qed
definition ‹regular_register F ⟷ register F ∧ (∃a. (F; complement F) (selfbutterket default ⊗⇩o a) = selfbutterket default)›
lemma regular_registerI:
assumes [simp]: ‹register F›
assumes [simp]: ‹complements F G›
assumes eq: ‹(F; G) (selfbutterket default ⊗⇩o a) = selfbutterket default›
shows ‹regular_register F›
proof -
have [simp]: ‹compatible F G›
using assms by (simp add: complements_def)
from ‹complements F G›
obtain I where cFI: ‹complement F o I = G› and ‹iso_register I›
apply atomize_elim
by (meson Laws_Complement_Quantum.complement_unique equivalent_registers_def equivalent_registers_sym)
have ‹(F; complement F) (selfbutterket default ⊗⇩o I a) = (F; G) (selfbutterket default ⊗⇩o a)›
using cFI by (auto simp: register_pair_apply)
also have ‹… = selfbutterket default›
by (rule eq)
finally show ?thesis
unfolding regular_register_def by auto
qed
lemma regular_register_pair:
assumes [simp]: ‹compatible F G›
assumes ‹regular_register F› and ‹regular_register G›
shows ‹regular_register (F;G)›
proof -
have [simp]: ‹bij (F;complement F)› ‹bij (G;complement G)›
using assms(1) compatible_def complement_is_complement complements_def iso_register_bij by blast+
have [simp]: ‹bij ((F;G);complement (F;G))›
using assms(1) complement_is_complement complements_def iso_register_bij pair_is_register by blast
have [simp]: ‹register F› ‹register G›
using assms(1) unfolding compatible_def by auto
obtain aF where [simp]: ‹inv (F;complement F) (selfbutterket default) = selfbutterket default ⊗⇩o aF›
by (metis assms(2) compatible_complement_right invI pair_is_register register_inj regular_register_def)
obtain aG where [simp]: ‹inv (G;complement G) (selfbutterket default) = selfbutterket default ⊗⇩o aG›
by (metis assms(3) complement_is_complement complements_def inj_iff inv_f_f iso_register_inv_comp1 regular_register_def)
define t1 where ‹t1 = inv ((F;G); complement (F;G)) (selfbutterket default)›
define t2 where ‹t2 = inv (F; (G; complement (F;G))) (selfbutterket default)›
define t3 where ‹t3 = inv (G; (F; complement (F;G))) (selfbutterket default)›
have ‹complements F (G; complement (F;G))›
apply (rule complements_complement_pair)
by simp
then have ‹equivalent_registers (complement F) (G; complement (F;G))›
using Laws_Complement_Quantum.complement_unique equivalent_registers_sym by blast
then obtain I where [simp]: ‹iso_register I› and I: ‹(G; complement (F;G)) = complement F o I›
by (metis equivalent_registers_def)
then have [simp]: ‹register I›
by (meson iso_register_is_register)
have [simp]: ‹bij (id ⊗⇩r I)›
by (rule iso_register_bij, simp)
have [simp]: ‹inv (id ⊗⇩r I) = id ⊗⇩r inv I›
by auto
have ‹t2 = (inv (id ⊗⇩r I) o inv (F;complement F)) (selfbutterket default)›
unfolding t2_def I
apply (subst o_inv_distrib[symmetric])
by (auto simp: pair_o_tensor)
also have ‹… = (selfbutterket default ⊗⇩o inv I aF)›
apply auto
by (metis ‹iso_register I› id_def iso_register_def iso_register_inv register_id register_tensor_apply)
finally have t2': ‹t2 = selfbutterket default ⊗⇩o inv I aF›
by simp
have *: ‹complements G (F; complement (F;G))›
apply (rule complements_complement_pair')
by simp
then have [simp]: ‹compatible G (F; complement (F;G))›
using complements_def by blast
from * have ‹equivalent_registers (complement G) (F; complement (F;G))›
using complement_unique equivalent_registers_sym by blast
then obtain J where [simp]: ‹iso_register J› and I: ‹(F; complement (F;G)) = complement G o J›
by (metis equivalent_registers_def)
then have [simp]: ‹register J›
by (meson iso_register_is_register)
have [simp]: ‹bij (id ⊗⇩r J)›
by (rule iso_register_bij, simp)
have [simp]: ‹inv (id ⊗⇩r J) = id ⊗⇩r inv J›
by auto
have ‹t3 = (inv (id ⊗⇩r J) o inv (G;complement G)) (selfbutterket default)›
unfolding t3_def I
apply (subst o_inv_distrib[symmetric])
by (auto simp: pair_o_tensor)
also have ‹… = (selfbutterket default ⊗⇩o inv J aG)›
apply auto
by (metis ‹iso_register J› id_def iso_register_def iso_register_inv register_id register_tensor_apply)
finally have t3': ‹t3 = selfbutterket default ⊗⇩o inv J aG›
by simp
have *: ‹((F;G); complement (F;G)) o assoc' = (F; (G; complement (F;G)))›
apply (rule tensor_extensionality3)
by (auto simp: register_pair_apply compatible_complement_pair1 compatible_complement_pair2)
have t2_t1: ‹t2 = assoc t1›
unfolding t1_def t2_def *[symmetric] apply (subst o_inv_distrib)
by auto
have *: ‹((F;G); complement (F;G)) o (swap ⊗⇩r id) o assoc' = (G; (F; complement (F;G)))›
apply (rule tensor_extensionality3)
apply (auto intro!: register_comp register_tensor_is_register pair_is_register complements_complement_pair
simp: register_pair_apply compatible_complement_pair1)
by (metis assms(1) cblinfun_assoc_left(1) swap_registers_left)
have t3_t1: ‹t3 = assoc ((swap ⊗⇩r id) t1)›
unfolding t1_def t3_def *[symmetric] apply (subst o_inv_distrib)
by (auto intro!: bij_comp simp: iso_register_bij o_inv_distrib)
from ‹t2 = assoc t1› ‹t3 = assoc ((swap ⊗⇩r id) t1)›
have *: ‹selfbutterket default ⊗⇩o inv J aG = assoc ((swap ⊗⇩r id) (assoc' (selfbutterket default ⊗⇩o inv I aF)))›
by (simp add: t2' t3')
have ‹selfbutterket default ⊗⇩o swap (inv J aG) = (id ⊗⇩r swap) (selfbutterket default ⊗⇩o inv J aG)›
by auto
also have ‹… = ((id ⊗⇩r swap) o assoc o (swap ⊗⇩r id) o assoc') (selfbutterket default ⊗⇩o inv I aF)›
by (simp add: *)
also have ‹… = (assoc o swap) (selfbutterket default ⊗⇩o inv I aF)›
apply (rule fun_cong[where g=‹assoc o swap›])
apply (intro tensor_extensionality3 register_comp register_tensor_is_register)
by auto
also have ‹… = assoc (inv I aF ⊗⇩o selfbutterket default)›
by auto
finally have *: ‹selfbutterket default ⊗⇩o swap (inv J aG) = assoc (inv I aF ⊗⇩o selfbutterket default)›
by -
obtain c where *: ‹selfbutterket (default::'c) ⊗⇩o swap (inv J aG) = selfbutterket default ⊗⇩o c ⊗⇩o selfbutterket default›
apply atomize_elim
apply (rule overlapping_tensor)
using * unfolding assoc_ell2_sandwich sandwich_def
by auto
have ‹t1 = ((swap ⊗⇩r id) o assoc') t3›
by (simp add: t3_t1 register_tensor_distrib[unfolded o_def, THEN fun_cong] flip: id_def)
also have ‹… = ((swap ⊗⇩r id) o assoc' o (id ⊗⇩r swap)) (selfbutterket (default::'c) ⊗⇩o swap (inv J aG))›
unfolding t3' by auto
also have ‹… = ((swap ⊗⇩r id) o assoc' o (id ⊗⇩r swap)) (selfbutterket default ⊗⇩o c ⊗⇩o selfbutterket default)›
unfolding * by simp
also have ‹… = selfbutterket default ⊗⇩o c›
apply (simp del: tensor_butterfly)
by (simp add: default_prod_def)
finally have ‹t1 = selfbutterket default ⊗⇩o c›
by -
then show ?thesis
apply (auto intro!: exI[of _ c] simp: regular_register_def t1_def)
by (metis ‹bij ((F;G);complement (F;G))› bij_inv_eq_iff)
qed
lemma regular_register_comp: ‹regular_register (F o G)› if ‹regular_register F› ‹regular_register G›
proof -
have [simp]: ‹register F› ‹register G›
using regular_register_def that by blast+
from that obtain a where a: ‹(F; complement F) (selfbutterket default ⊗⇩o a) = selfbutterket default›
unfolding regular_register_def by metis
from that obtain b where b: ‹(G; complement G) (selfbutterket default ⊗⇩o b) = selfbutterket default›
unfolding regular_register_def by metis
have ‹complements (F o G) (complement F; F o complement G)›
by (simp add: complements_chain)
then have ‹equivalent_registers (complement F; F o complement G) (complement (F o G))›
using complement_unique by blast
then obtain J where [simp]: ‹iso_register J› and 1: ‹(complement F; F o complement G) o J = (complement (F o G))›
using equivalent_registers_def by blast
have [simp]: ‹register J›
by (simp add: iso_register_is_register)
define c where ‹c = inv J (a ⊗⇩o b)›
have ‹((F o G); complement (F o G)) (selfbutterket default ⊗⇩o c) = ((F o G); (complement F; F o complement G)) (selfbutterket default ⊗⇩o J c)›
by (auto simp flip: 1 simp: register_pair_apply)
also have ‹… = ((F o (G; complement G); complement F) o assoc' o (id ⊗⇩r swap)) (selfbutterket default ⊗⇩o J c)›
apply (subst register_comp_pair[symmetric])
apply auto[2]
apply (subst pair_o_assoc')
apply auto[3]
apply (subst pair_o_tensor)
by auto
also have ‹… = ((F o (G; complement G); complement F) o assoc') (selfbutterket default ⊗⇩o swap (J c))›
by auto
also have ‹… = ((F o (G; complement G); complement F) o assoc') (selfbutterket default ⊗⇩o (b ⊗⇩o a))›
unfolding c_def apply (subst surj_f_inv_f[where f=J])
apply (meson ‹iso_register J› bij_betw_inv_into_right iso_register_inv_comp1 iso_register_inv_comp2 iso_tuple_UNIV_I o_bij surj_iff_all)
by auto
also have ‹… = (F ∘ (G;complement G);complement F) ((selfbutterket default ⊗⇩o b) ⊗⇩o a)›
by (simp add: assoc'_apply)
also have ‹… = (F; complement F) ((G;complement G) (selfbutterket default ⊗⇩o b) ⊗⇩o a)›
by (simp add: register_pair_apply')
also have ‹… = selfbutterket default›
by (auto simp: a b)
finally have ‹(F ∘ G;complement (F ∘ G)) (selfbutterket default ⊗⇩o c) = selfbutterket default›
by -
then show ?thesis
using ‹register F› ‹register G› register_comp regular_register_def by blast
qed
lemma regular_iso_register:
assumes ‹regular_register F›
assumes [register]: ‹iso_register F›
shows ‹F (selfbutterket default) = selfbutterket default›
proof -
from assms(1) obtain a where a: ‹(F;complement F) (selfbutterket default ⊗⇩o a) = selfbutterket default›
using regular_register_def by blast
let ?u = ‹empty_var :: (unit ell2 ⇒⇩C⇩L unit ell2) ⇒ _›
have ‹is_unit_register ?u› and ‹is_unit_register (complement F)›
by auto
then have ‹equivalent_registers (complement F) ?u›
using unit_register_unique by blast
then obtain I where ‹iso_register I› and ‹complement F = ?u o I›
by (metis ‹is_unit_register (complement F)› equivalent_registers_def is_unit_register_empty_var unit_register_unique)
have ‹selfbutterket default = (F; ?u o I) (selfbutterket default ⊗⇩o a)›
using ‹complement F = empty_var ∘ I› a by presburger
also have ‹… = (F; ?u) (selfbutterket default ⊗⇩o I a)›
by (metis Laws_Quantum.register_pair_apply ‹complement F = empty_var ∘ I› ‹equivalent_registers (complement F) empty_var› assms(2) comp_apply complement_is_complement complements_def equivalent_complements iso_register_is_register)
also have ‹… = (F; ?u) (selfbutterket default ⊗⇩o (one_dim_iso (I a) *⇩C id_cblinfun))›
by simp
also have ‹… = one_dim_iso (I a) *⇩C (F; ?u) (selfbutterket default ⊗⇩o id_cblinfun)›
by (simp add: Axioms_Quantum.register_pair_apply empty_var_def iso_register_is_register)
also have ‹… = one_dim_iso (I a) *⇩C F (selfbutterket default)›
by (auto simp: register_pair_apply iso_register_is_register simp del: id_cblinfun_eq_1)
finally have F: ‹one_dim_iso (I a) *⇩C F (selfbutterket default) = selfbutterket default›
by simp
from F have ‹one_dim_iso (I a) ≠ (0::complex)›
by (metis butterfly_apply butterfly_scaleC_left complex_vector.scale_eq_0_iff id_cblinfun_eq_1 id_cblinfun_not_0 cinner_ket_same ket_nonzero one_dim_iso_of_one one_dim_iso_of_zero')
have ‹selfbutterket default = one_dim_iso (I a) *⇩C F (selfbutterket default)›
using F by simp
also have ‹… = one_dim_iso (I a) *⇩C F (selfbutterket default o⇩C⇩L selfbutterket default)›
by auto
also have ‹… = one_dim_iso (I a) *⇩C (F (selfbutterket default) o⇩C⇩L F (selfbutterket default))›
by (simp add: assms(2) iso_register_is_register register_mult)
also have ‹… = one_dim_iso (I a) *⇩C ((selfbutterket default /⇩C one_dim_iso (I a)) o⇩C⇩L (selfbutterket default /⇩C one_dim_iso (I a)))›
by (metis (no_types, lifting) F ‹one_dim_iso (I a) ≠ 0› complex_vector.scale_left_imp_eq inverse_1 left_inverse scaleC_scaleC zero_neq_one)
also have ‹… = one_dim_iso (I a) *⇩C selfbutterket default›
by (smt (verit, best) butterfly_comp_butterfly calculation cblinfun_compose_scaleC_left cblinfun_compose_scaleC_right complex_vector.scale_cancel_left cinner_ket_same left_inverse scaleC_one scaleC_scaleC)
finally have ‹one_dim_iso (I a) = (1::complex)›
by (metis butterfly_0_left butterfly_apply complex_vector.scale_cancel_right cinner_ket_same ket_nonzero scaleC_one)
with F show ‹F (selfbutterket default) = selfbutterket default›
by simp
qed
lemma pure_state_nested:
assumes [simp]: ‹compatible F G›
assumes ‹regular_register H›
assumes ‹iso_register H›
shows ‹pure_state (F;G) (pure_state H h ⊗⇩s g) = pure_state ((F o H);G) (h ⊗⇩s g)›
proof -
note [[simproc del: Laws_Quantum.compatibility_warn]]
have [simp]: ‹register H›
by (meson assms(3) iso_register_is_register)
have [simp]: ‹H (selfbutterket default) = selfbutterket default›
apply (rule regular_iso_register)
using assms by auto
have 1: ‹pure_state_target_vector H (ket default) = ket default›
apply (rule pure_state_target_vector_ket_default)
apply auto
by (metis (no_types, lifting) cinner_ket_same rangeI scaleC_one)
have ‹butterfly (pure_state H h) (ket default) = butterfly (H (butterfly h (ket default)) *⇩V ket default) (ket default)›
by (simp add: pure_state'_def 1)
also have ‹… = H (butterfly h (ket default)) o⇩C⇩L selfbutterket default›
by (metis (no_types, opaque_lifting) adj_cblinfun_compose butterfly_adjoint butterfly_comp_cblinfun double_adj)
also have ‹… = H (butterfly h (ket default)) o⇩C⇩L H (selfbutterket default)›
by simp
also have ‹… = H (butterfly h (ket default) o⇩C⇩L selfbutterket default)›
by (meson ‹register H› register_mult)
also have ‹… = H (butterfly h (ket default))›
by auto
finally have 2: ‹butterfly (pure_state H h) (ket default) = H (butterfly h (ket default))›
by simp
show ?thesis
apply (rule pure_state_eqI)
using 1 2
by (auto simp: register_pair_butterfly_tensor compatible_ac_rules default_prod_def simp flip: tensor_ell2_ket)
qed
lemma state_apply1:
assumes [register]: ‹compatible F G›
shows ‹F U *⇩V (F ψ ⊗⇩p G φ) = (F (U ψ) ⊗⇩p G φ)›
proof -
have [register]: ‹compatible F G›
using assms(1) complements_def by blast
have ‹F U *⇩V (F ψ ⊗⇩p G φ) = (F;G) (U ⊗⇩o id_cblinfun) *⇩V (F ψ ⊗⇩p G φ)›
apply (subst register_pair_apply)
by auto
also have ‹… = (F (U ψ) ⊗⇩p G φ)›
unfolding pure_state'_def
by (auto simp: register_mult' cblinfun_comp_butterfly tensor_op_ell2)
finally show ?thesis
by -
qed
lemma Fst_regular[simp]: ‹regular_register Fst›
apply (rule regular_registerI[where a=‹selfbutterket default› and G=Snd])
by (auto simp: pair_Fst_Snd default_prod_def)
lemma Snd_regular[simp]: ‹regular_register Snd›
apply (rule regular_registerI[where a=‹selfbutterket default› and G=Fst])
apply auto[2]
apply (auto simp only: default_prod_def swap_apply simp flip: swap_def)
by auto
lemma id_regular[simp]: ‹regular_register id›
apply (rule regular_registerI[where G=unit_register and a=id_cblinfun])
by (auto simp: register_pair_apply)
lemma swap_regular[simp]: ‹regular_register swap›
by (auto intro!: regular_register_pair simp: swap_def)
lemma assoc_regular[simp]: ‹regular_register assoc›
by (auto intro!: regular_register_pair regular_register_comp simp: assoc_def)
lemma assoc'_regular[simp]: ‹regular_register assoc'›
by (auto intro!: regular_register_pair regular_register_comp simp: assoc'_def)
lemma cspan_pure_state':
assumes ‹iso_register F›
assumes ‹cspan (g ` X) = UNIV›
assumes η_cond: ‹F (selfbutter η) *⇩V pure_state_target_vector F η ≠ 0›
shows ‹cspan ((λz. pure_state' F (g z) η) ` X) = UNIV›
proof -
from iso_register_decomposition[of F]
obtain U where [simp]: ‹unitary U› and F: ‹F = sandwich U›
using assms(1) by blast
define η' c where ‹η' = pure_state_target_vector F η› and ‹c = cinner (U *⇩V η) η'›
from η_cond
have ‹c ≠ 0›
by (simp add: η'_def F sandwich_def c_def cinner_adj_right)
have ‹cspan ((λz. pure_state' F (g z) η) ` X) = cspan ((λz. F (butterfly (g z) η) *⇩V η') ` X)›
by (simp add: η'_def pure_state'_def)
also have ‹… = cspan ((λz. (butterfly (U *⇩V g z) (U *⇩V η)) *⇩V η') ` X)›
by (simp add: F sandwich_def cinner_adj_right)
also have ‹… = cspan ((λz. c *⇩C U *⇩V g z) ` X)›
by (simp add: c_def)
also have ‹… = (λz. c *⇩C U *⇩V z) ` cspan (g ` X)›
apply (subst complex_vector.linear_span_image[symmetric])
by (auto simp: image_image)
also have ‹… = (λz. c *⇩C U *⇩V z) ` UNIV›
using assms(2) by presburger
also have ‹… = UNIV›
apply (rule surjI[where f=‹λz. (U* *⇩V z) /⇩C c›])
using ‹c ≠ 0› by (auto simp flip: cblinfun_apply_cblinfun_compose)
finally show ?thesis
by -
qed
lemma cspan_pure_state:
assumes [simp]: ‹iso_register F›
assumes ‹cspan (g ` X) = UNIV›
shows ‹cspan ((λz. pure_state F (g z)) ` X) = UNIV›
apply (rule cspan_pure_state')
using assms apply auto[2]
apply (rule pure_state_target_vector_correct)
by (auto simp: iso_register_is_register)
lemma pure_state_bounded_clinear:
assumes [register]: ‹compatible F G›
shows ‹bounded_clinear (λψ. (F ψ ⊗⇩p G φ))›
proof -
have [bounded_clinear]: ‹bounded_clinear (F;G)›
using assms pair_is_register register_bounded_clinear by blast
show ?thesis
unfolding pure_state'_def
by (auto intro!: bounded_linear_intros)
qed
lemma pure_state_bounded_clinear_right:
assumes [register]: ‹compatible F G›
shows ‹bounded_clinear (λφ. (F ψ ⊗⇩p G φ))›
proof -
have [bounded_clinear]: ‹bounded_clinear (F;G)›
using assms pair_is_register register_bounded_clinear by blast
show ?thesis
unfolding pure_state'_def
by (auto intro!: bounded_linear_intros)
qed
lemma pure_state_clinear:
assumes [register]: ‹compatible F G›
shows ‹clinear (λψ. (F ψ ⊗⇩p G φ))›
using assms bounded_clinear.clinear pure_state_bounded_clinear by blast
method pure_state_flatten_nested =
(subst pure_state_nested, (auto; fail)[3])+
text ‹The following method ‹pure_state_eq› tries to solve a equality where both sides are of the form
‹F⇩1(ψ⇩1) ⊗⇩p F⇩2(ψ⇩2) ⊗⇩p … ⊗⇩p F⇩n(ψ⇩n)› by reordering the registers and unfolding nested register pairs.
(For the unfolding of nested pairs, it is necessary that the corresponding \<^term>‹compatible F G› facts are provable by the simplifier.)
If the some of the pure states \<^term>‹ψ⇩i› themselves are ‹⊗⇩p›-tensors, they will be flattened if possible.
(If all necessary conditions can be proven, such as ‹regular_register› etc.)
The method may either succeed, fail, or reduce the equality to a hopefully simpler one.›
method pure_state_eq =
(pure_state_flatten_nested?,
rule pure_state_eqI;
auto simp: register_pair_butterfly_tensor compatible_ac_rules default_prod_def
simp flip: tensor_ell2_ket)
lemma example:
fixes F :: ‹bit update ⇒ 'c::{finite,default} update›
and G :: ‹bit update ⇒ 'c update›
assumes [register]: ‹compatible F G›
shows ‹(F;G) CNOT o⇩C⇩L (G;F) CNOT o⇩C⇩L (F;G) CNOT = (F;G) swap_ell2›
proof -
define Z where ‹Z = complement (F;G)›
then have [register]: ‹compatible Z F› ‹compatible Z G›
using assms compatible_complement_pair1 compatible_complement_pair2 compatible_sym by blast+
have [simp]: ‹iso_register (F;(G;Z))›
using Z_def assms complements_complement_pair complements_def by blast
have eq1: ‹((F;G) CNOT o⇩C⇩L (G;F) CNOT o⇩C⇩L (F;G) CNOT) *⇩V (F(ket f) ⊗⇩p G(ket g) ⊗⇩p Z(ket z))
= (F;G) swap_ell2 *⇩V (F(ket f) ⊗⇩p G(ket g) ⊗⇩p Z(ket z))› for f g z
proof -
have ‹(F(ket f) ⊗⇩p G(ket g) ⊗⇩p Z(ket z)) = ((F;G) (ket f ⊗⇩s ket g) ⊗⇩p Z(ket z))›
by pure_state_eq
also have ‹(F;G) CNOT *⇩V … = ((F;G) (ket f ⊗⇩s ket (g+f)) ⊗⇩p Z(ket z))›
apply (subst state_apply1) by auto
also have ‹… = ((G;F) (ket (g+f) ⊗⇩s ket f) ⊗⇩p Z(ket z))›
by pure_state_eq
also have ‹(G;F) CNOT *⇩V … = ((G;F) (ket (g+f) ⊗⇩s ket g) ⊗⇩p Z ket z)›
apply (subst state_apply1) by auto
also have ‹… = ((F;G) (ket g ⊗⇩s ket (g+f)) ⊗⇩p Z ket z)›
by pure_state_eq
also have ‹(F;G) CNOT *⇩V … = ((F;G) ket g ⊗⇩s ket f ⊗⇩p Z ket z)›
apply (subst state_apply1)
apply simp
using add_right_imp_eq by fastforce
also have ‹… = (F(ket g) ⊗⇩p G(ket f) ⊗⇩p Z(ket z))›
by pure_state_eq
finally have 1: ‹((F;G) CNOT o⇩C⇩L (G;F) CNOT o⇩C⇩L (F;G) CNOT) *⇩V (F(ket f) ⊗⇩p G(ket g) ⊗⇩p Z(ket z)) = (F(ket g) ⊗⇩p G(ket f) ⊗⇩p Z(ket z))›
by auto
have ‹(F(ket f) ⊗⇩p G(ket g) ⊗⇩p Z(ket z)) = ((F;G) (ket f ⊗⇩s ket g) ⊗⇩p Z(ket z))›
by pure_state_eq
also have ‹(F;G) swap_ell2 *⇩V … = ((F;G) (ket g ⊗⇩s ket f) ⊗⇩p Z(ket z))›
by (auto simp: state_apply1 swap_ell2_tensor simp del: tensor_ell2_ket)
also have ‹… = (F(ket g) ⊗⇩p G(ket f) ⊗⇩p Z(ket z))›
by pure_state_eq
finally have 2: ‹(F;G) swap_ell2 *⇩V (F(ket f) ⊗⇩p G(ket g) ⊗⇩p Z(ket z)) = (F(ket g) ⊗⇩p G(ket f) ⊗⇩p Z(ket z))›
by -
from 1 2 show ?thesis
by simp
qed
then have eq1: ‹((F;G) CNOT o⇩C⇩L (G;F) CNOT o⇩C⇩L (F;G) CNOT) *⇩V ψ
= (F;G) swap_ell2 *⇩V ψ› if ‹ψ ∈ {(F(ket f) ⊗⇩p G(ket g) ⊗⇩p Z(ket z))| f g z. True}› for ψ
using that by auto
moreover have ‹cspan {(F(ket f) ⊗⇩p G(ket g) ⊗⇩p Z(ket z))| f g z. True} = UNIV›
apply (simp only: double_exists setcompr_eq_image full_SetCompr_eq)
apply simp
apply (rule cspan_pure_state)
by auto
ultimately show ?thesis
using cblinfun_eq_on_UNIV_span by blast
qed
end